perm filename PASCAL.PAS[PAS,SYS]8 blob
sn#483430 filedate 1979-10-24 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00042 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 (*$T-,D-,S1700,R30*) (*STANFORD LOTS PASCAL COMPILER*)
C00014 00003 (*HISTORY*)
C00028 00004 (*SWITCHES - OPTIONS*)
C00035 00005 (*NAMING CONVENTIONS*)
C00037 00006 (*IMPLEMENTATION: WHAT YOU NEED AND HOW YOU DO IT*)
C00046 00007 (*LIMITATIONS*)
C00048 00008 (*MAINTENANCE INFORMATION*)
C00054 00009 (*THE SYMBOL TABLE DATA STRUCTURE*)
C00084 00010 (*LINKAGE CONVENTIONS*)
C00097 00011 (*PACKING POLICY*)
C00103 00012 (* GLOBAL DECLARATIONS. *)
C00113 00013 TYPE
C00132 00014 VAR
C00158 00015 (* INITPROCEDURES. *)
C00223 00016 (* INIT_COMPILE, PUTADR, LOCATION, INITPASSGO, ERROR *)
C00231 00017 (*SYMBOL TABLE INIT: ENTERID, ENTERSTDTYPES, ENTERSTDNAMES, ENTERUNDECL*)
C00258 00018 (*GET_DIRECTIVES*)
C00271 00019 (* COMPILE[ NEWPAGER, WRITEBUFFER, GETNEXTLINE, FINISHLINE, ERROR_WITH_TEXT, WARNING*)
C00283 00020 (*INSYMBOL[NEXTCH, SKIPCOMMENT[OPTIONS], SKIP_E_DIRECTORY*)
C00292 00021 (*]INSYMBOL*)
C00303 00022 (*SEARCHSECTION, SEARCHID, SKIPIFERR, IFERRSKIP, ERRANDSKIP*)
C00308 00023 (* BLOCK[ TYPE CHECKING: CONSTANT, GETBOUNDS, STRING, COMPTYPES[CHECKSSTRING[ISMAGIC]] *)
C00321 00024 (* TYPEDEFINITION (TYPE DEFINITION PARSER) *)
C00348 00025 (* PARSING OF DECLARATIONS: LABELDECLARATION, CONSTANTDECLARATION, TYPEDECLARATION, VARIABLEDECLARATION, proceduredeclaration[parameterlist[ffparlist]] *)
C00377 00026 (* BODY[GENERATE_WORD,INSERT_ADDRESS,INCREMENT_REGC,DEPOSIT_CONSTANT,MACRO..,PUT_PAGENUMBER,PUT_LINENUMBER,SUPPORT,ALFACONSTANT,ADDNEWCOUNTER*)
C00390 00027 (*CLOSEFILES, ENTERBODY, LEAVEBODY*)
C00411 00028 (*FETCH_BASIS,GET_PARAMETER_ADDRESS,GENERATE_CODE,LOAD,STORE,LOAD_ADDRESS*)
C00424 00029 (* WRITE_MACHINE_CODE[ AND ITS PARTS. *)
C00465 00030 (* PARTS. ]WRITE_MACHINE_CODE. *)
C00483 00031 (* STATEMENT[ MAKEREAL, SELECTOR[SUBLOWBOUND] *)
C00497 00032 (* PROFUNCALL[GETFILENAME,variable,GETPUTRESETREWRITE,READREADLN,BREAKCALL,WRITEWRITELN,MESSAGECALL*)
C00523 00033 (* PACKUNPACK, NEWDISPOSE, FIRSTLAST, LOWERUPPERBOUND *)
C00544 00034 (*MINMAX,GETLINENRCALL,PAGECALL,DATECALL,TIMECALL,CLOCKCALL,CARDCALL*)
C00552 00035 (*ABSCALL,REALTIMECALL,SQRCALL,ODDCALL,ORDCALL,CHRCALL,PREDSUCC,EOFEOLN,PROTECTION,CALLTOCALL[GETSTRINGADDRESS],HALTCALL*)
C00561 00036 (*CALL_NON_STANDARD[COMPPARAM,CHECKSSTRINGCALLS,CHARCONSTANT,saveexpr] ]PROFUNCALL*)
C00588 00037 (* EXPRESSION[CHANGEBOOL, SEARCHCODE, SIMPLEEXPRESSION[TERM[FACTOR]]] *)
C00620 00038 (* ASSIGNMENT[STOREGLOBALS[STOREWORD,GETNEWGLOBPTR]] *)
C00631 00039 (*GOTOSTATEMENT,COMPOUNDSTATEMENT,IFSTATEMENT,CASESTATEMENT,REPEATSTATEMENT,WHILESTATEMENT,FORSTATEMENT,LOOPSTATEMENT,WITHSTATEMENT*)
C00654 00040 (* ]STATEMENT ]BODY ]BLOCK *)
C00667 00041 (* ]COMPILE,REPORTTIME,JUMPTO *)
C00677 00042 (* MAIN BODY *)
C00689 ENDMK
C⊗;
(*$T-,D-,S1700,R30*) (*STANFORD LOTS PASCAL COMPILER*)
(********************************************************************************
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1976,
* H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG-13
* GERMANY
*
* P A S C A L / P A S S G O
* -----------------------------
*
* ONE-SOURCE, TWO-OBJECT COMPILER FOR PASCAL, PRODUCED AT STANFORD
* UNIVERSITY FROM THE DECSYSTEM-10 PASCAL COMPILER WRITTEN BY
* H. H. NAGEL, UNIVERSITY OF HAMBURG. AUG-1978.
*
* (A) IF THIS SOURCE IS COMPILED WITH THE SWITCH OPTION /VERSION:1,
* THE OBJECT CODE IS A FULL PASCAL COMPILER, AS DESCRIBED
* BY NAGEL, WITH SOME IMPROVEMENTS. WE WILL REFER TO IT
* AS PASCAL, OR THE FULL (F) COMPILER.
* (B) IF IT IS COMPILED WITH THE SWITCH OPTIONS /VERSION:2/NOTTY/NOOUTPUT,
* THE OBJECT CODE IS AN INCORE COMPILE-AND-GO COMPILER
* WITH A MINIMUM OF OPTIONS, WHICH WILL NOT ALLOW FOR
* EXTERNAL PROCEDURES, BUT BESIDES THAT, IT SUPPORTS
* EVERYTHING ELSE THE OTHER COMPILER SUPPORTS.
* WE WILL REFER TO IT AS PASSGO, OR THE INCORE (I) COMPILER.
* (C) VERSION NUMBERS 3 AND 4 ARE LOCAL TO STANFORD, FOR THE COMPUTER AT THE
* ARTIFICIAL INTELLIGENCE LABORATORY. VERSION 3 IS LIKE VERSION 1,
* AND VERSION 4 IS LIKE VERSION 2.
*
* TO COMPILE THIS COMPILER YOU NEED THE OBJECT CODE OF CASE (A), (AT SAIL, C3)
* THAT IS, A FULL PASCAL COMPILER WITH SOME ADDITIONS.
*
********************************************************************************)
(*HISTORY*)
(********************************************************************************
*
* HISTORY OF PREVIOUS VERSIONS
* ****************************
*
*
* MAR-73 SYNTAX ANALYSIS INCLUDING ERROR HANDLING,
* CHECKS BASED ON DECLARATIONS AND ADDRESS-
* AND CODE-GENERATION FOR A HYPOTHETICAL
* STACK COMPUTER BY URS AMMAN
*
* FACHGRUPPE COMPUTER-WISSENSCHAFTEN
* EIDG. TECHNISCHE HOCHSCHULE
* CH-8006 ZUERICH
*
* DEC-73 CODE-GENERATION FOR DECSYSTEM-10
* BY C.O. GROSSE-LINDEMANN, F.W. LORENZ,
* H.H. NAGEL AND P.J. STIRL /1/
*
* JUL-74 IMPLEMENTATION OF NEW FEATURES BY STUDENTS
* DURING A PRACTICAL PROGRAMMING COURSE /2/
*
* DEC-74 MODIFICATIONS TO GENERATE RELOCATABLE
* LINK-10 OBJECT-CODE BY E. KISICKI
*
* DEC-74 DEBUG SYSTEM /5/
* BY P. PUTFARKEN
*
* APR-76 POST-MORTEM DUMP FACILITY /6/
* BY B. NEBEL AND B. PRETSCHNER
*
* AUG-76 IMPROVEMENTS AND ADAPTATION TO STANDARD-PASCAL
* AND CDC 6000-3.4. PASCAL AS PRESENTED IN
* "PASCAL - USER MANUAL AND REPORT" /3,4,7/
* BY E.KISICKI
*
* NOV-76 FORMAL PROCEDURE/FUNCTION PARAMETERS
* AND CORRECTION OF ERRORS
* BY H. LINDE
*
* INSTITUT FUER INFORMATIK
* SCHLUETERSTRASSE 70
* D-2000 HAMBURG 13
*
* /1/ F.W. LORENZ, P.J. STIRL
* UEBERTRAGUNG EINES PASCAL-COMPILERS AUF DAS DECSYSTEM-10
* DIPLOMARBEIT, IFI, HH, 74
*
* C.O. GROSSE-LINDEMANN, H.H. NAGEL
* POSTLUDE TO A PASCAL-COMPILER BOOTSTRAP
* BERICHT NR. 11, IFI, HH, 74
*
* C.O. GROSSE-LINDEMANN
* WEITERFUEHRENDE ARBEITEN AM PASCAL-COMPILER ZUR
* STEIGERUNG DER BENUTZERFREUNDLICHKEIT
* DIPLOMARBEIT, IFI, HH, 75
*
* /2/ ERWEITERUNG VON SPRACHDEFINITION, COMPILER UND LAUFZEIT-
* UNTERSTUETZUNG BEI PASCAL/ ERGEBNISSE EINES PRAKTIKUMS
* IM INFORMATIK GRUNDSTUDIUM
* STUD. BEITRAEGE BEARBEITET VON H.H. NAGEL
* MITTEILUNGEN NR. 16, IFI, HH, 75
*
* /3/ H.H. NAGEL
* PASCAL FOR DECSYSTEM-10/ EXPERIENCES AND FURTHER PLANS
* MITTEILUNGEN NR. 21, IFI, HH, NOV-75
*
* /4/ KATHLEEN JENSEN, NIKLAUS WIRTH
* PASCAL USER MANUAL AND REPORT
* LECTURE NOTES IN COMPUTER SCIENCE VOL 18
* SPRINGER-VERLAG BERLIN-HEIDELBERG-NEW YORK
*
* /5/ P. PUTFARKEN
* TESTHILFEN FUER PASCAL PROGRAMME
* DIPLOMARBEIT, IFI, HH, 76
*
* /6/ B. NEBEL, B. PRETSCHNER
* ERWEITERUNG DES DECSYSTEM-10 PASCAL COMPILERS UM
* EINE MOEGLICHKEIT ZUR ERZEUGUNG EINES POST-MORTEM DUMP
* MITTEILUNGEN NR. 34 , IFI, HH, JUN-76
*
* /7/ E. KISICKI, H.H. NAGEL
* PASCAL FOR THE DECSYSTEM-10
* MITTEILUNGEN NR. , IFI, HH, NOV-76
*
********************************************************************************)
(********************************************************************************
*
* CHANGES MADE AT LOTS, STANFORD UNIVERSITY:
* N.B. THE LETTER AFTER THE FIX NUMBER MEANS THE FIX AFFECTS
* F - ONLY THE FULL COMPILER, PASCAL
* I - ONLY THE INCORE COMPILER, PASSGO
* B - BOTH.
*
* JAN-78 JOHN HENNESSY.
* (0)B CHANGES NEEDED TO IMPLEMENT AT LOTS.
*
* JUN-78 MAN CHOR KO.
* (1)F MODIFY THE CCL SCANNER (GETFILENAME) TO
* TAKE THE LOCAL STANDARD: SWITCHES IN THE FIRST LINE,
* SECOND LINE FOR A FILE NAME TO BE CALLED AFTER THE COMPILER.
*
* JUL-78 ARMANDO R. RODRIGUEZ. SMALL FIXINGS:
* (2)B AVOID RECURSION ON SCANNING COMMENTS.
* (3)B DON'T TAKE '\' AS A COMMENT END UNLESS STARTED BY '%'.
* (4)B CALL PCREF AND PASS IT ITS PARAMETERS PROPERLY.
* (5)F USE A BIG VALUE FOR RUNCORE.
* (6)B GIVE PAGE NUMBERS ON TTY.
* (7)B KNOW ABOUT SEVERAL NEW RUNTIMES FROM THE CCL SCANNER.
* (8)B IMPLEMENT THE SWITCH /VERSION:<GOODVERSION>, OPTION
* V<GOODVERSION>, TO ALLOW FOR CONDITIONAL COMPILATION: IF
* A COMMENT IS OPEN WITH %<N> WHERE <N> IS THE SAME DIGIT AS
* <GOODVERSION>, INCLUDE IT.
* (9)B CCL SCANNER: IF A DEVICE NAME IS GIVEN, DON'T
* ASUME THE FILE NAME WAS DEFAULTED.
* (10)B WORK PROPERLY WITH ALL COMPILE-CLASS COMMANDS, INCLUDING DEBUG.
* (11)F WHEN GETTING PARAMETER FILE NAMES FROM TTY, ALLOW
* FOR DEFAULT OF OBJECT AND LIST FILES: DEFAULT TO <SOURCE>.REL AND .LST.
* (12)B RUNTIME CHECK FOR NIL OR ZERO POINTERS.
* (13)B OTHER SMALL FIXINGS: REORDER BODY OF INITPROCEDURES;
* APPROPRIATE MESSAGE ON SEGMENTED FILES; TAKE LOADER TMPCORE
* FILE FROM DEBUG COMMAND PROPERLY; TAKE U- SWITCH PROPERLY;
* CANCEL LOAD IF E+ SWITCH PRESENT; ACCEPT EXTRA SEMICOLONS
* IN CASE, BOTH RECORD AND STATEMENT; ACCEPT NULL VARIANT
* PARTS OF RECORDS; PROMPT TTY INPUT FILES PROPERLY; SEND
* BEL ONLY IF NOT CALLING LOADER; COUNT ERRORS OF THE WHOLE
* FILE IN MULTIPLE-PROGRAM FILES; REWRITE OUTPUT ONLY IF NEEDED.
*
* AUG-78 ARMANDO R. RODRIGUEZ. CREATE PASSGO:
* (14)I OUT-COMMENT THE PASCAL FEATURES THAT ARE NOT PASSGO. (MAINLY SWITCHES.)
* (15)I ADD THE PASSGO VERSION OF THINGS WHICH ARE SIMILAR.
* (16)B (THANKS TO KO) FIX A BUG BY WHICH, WHEN YOU READ OR
* WRITE AN ARRAY ELEMENT SUBSCRIPTED BY A MOD EXPRESSION, THE
* GENERATED CODE WOULD READ/WRITE THE CORRESPONDING DIV EXPRESSION,
* INSTEAD OF THE ARRAY ELEMENT. (SUPPRESSED 9-AUG-78. IT INDUCED ANOTHER BUG.)
* (17)I SUPPRESS EXTERN/FORTRAN PROCEDURES , INITPROCEDURES
* AND LIBRARY CALLS FROM PASSGO.
* (18)I SUPPRESS FILE OBJECT, AND THE "TRIVIAL" LINK ITEMS.
* WRITE THE CODE INTO A LARGE ARRAY.
* (19)I WHEN IT FINDS A CALL TO A RUNTIME, GENERATE CODE
* CONTAINING THE ACTUAL ADDRESS OF IT.
* (20)I MOVE THE FILEBLOCKS BEING GENERATED TO THE START OF
* THE ARRAY OF CODE, SO THAT PASSGO CAN WRITE ON THEM WITHOUT
* DAMAGING ITS OWN DATA AREA.
* (21)I GENERATE CODE TO CALL SETTIME AND TIMEREPORT, AND
* TO LINK PROPERLY TO PCREF; CALL DEBUG PROPERLY. (TO DO THIS,
* USE THE SAME FILEBLOCKS FOR STANDARD FILES IN PASSGO AND
* IN THE USER PROGRAM.)
* (22)B AVOID GENERATION OF CODE IN THE CASE THAT ANY ERROR
* HAS BEEN DETECTED. (SPEED-UP).
* (23)B TO SIMPLIFY CONSISTENCY, USE THE LIBRARY ROUTINES
* TO REPORT RUNTIME AND FOR GET_DIRECTIVES.
* (24)I IMPLEMENT INITPROCEDURES IN PASSGO: GENERATE NORMAL
* CODE, AND CALL THEM AT THE BEGINNING.
*
* SEP-78 ARMANDO R. RODRIGUEZ.
* (25)B IMPLEMENT A NON-STANDARD STRING PACKAGE. TO
* DISABLE IT, CHANGE THE CONSTANT STRINGPACK TO FALSE.
* (26)I SUPPORT A SWITCH /SHOW TO DISPLAY THE RUNTIME
* MEMORY ORGANIZATION.
*
* MAR-79 ARMANDO R. RODRIGUEZ.
* (27)B SUPPORT MORE NICELY THE SOURCE FILES WITH NO
* LINE NUMBERS: USE PROCEDURE NAME INSTEAD OF PAGE ON ERROR
* MESSAGES, AND PRODUCE A .PRC FILE.
* (28)B (AS IMPLEMENTED BY PHILIP WISOFF) PRODUCE STATEMENT
* COUNTS: INSERT COUNTER INSTRUCTIONS AND DATA AREA, AND A
* CALL TO A COUNT DUMPER, THAT PRODUCES A .KNT FILE, USABLE
* BY PCREF FROM 10-MAR-79.
* (29)B ADD THE PREDEFINED PROCEDURE SETRAN, AND MAKE CALLS
* TO SQRT PASS THROUGH PSQRT, TO DETECT NEGATIVE NUMBERS.
* (30)B CHANGES IN ERROR MESSAGES: IF THE ERROR OCCURS IN THE
* FIRST TOKEN OF THE LINE, SUGGEST CHECKING THE PREVIOUS LINE.
* ADD A NEW MESSAGE FOR THE CASE WHEN THE GLOBALS NEED MORE
* MEMORY SPACE THAN THE LOWER SEGMENT CAN GIVE.
* (31)F SWITCHES /NOTTY AND /NOOUTPUT TO TELL THAT EXTERNAL
* PROCEDURES DON'T NEED THOSE FILES.
* (32)B MESSAGE WOULD BLOW WHEN NEEDING LAST A PASCAL-WRITTEN RUNTIME. FIXED.
*
********************************************************************************)
(*SWITCHES - OPTIONS*)
(*******************************************************************************************
*
* <PROGRAM LIBRARY> ::= [<OPTION SEQUENCE>] [<PROGRAM>]*
* <PROGRAM> ::= <PROGRAM HEADING><BLOCK>.
* <PROGRAM HEADING> ::= PROGRAM <PROGRAMNAME>
* [,<ENTRY>]*
* [(<FILE IDENTIFIER>[,<FILE IDENTIFIER>]* )];
* <OPTION SEQUENCE> ::= ( *$ <OPTION>[,<OPTION>]* <ANY COMMENT> * )
* <OPTION> ::= <LETTER><SIGN>
* <LETTER> ::= [D, E, L, P, T, U]
* <SIGN> ::= [+, -]
*
* <PROGRAMNAME> ::= <IDENTIFIER>
* <FILE IDENTIFIER> ::= <IDENTIFIER>
* <ENTRY> ::= <IDENTIFIER>
*
************************************ COMPILER OPTIONS ************************************
*
* DEC-10 PASCAL FUNCTION DEFAULT
*
* [NO]LOG G+/G- SEND THE ERROR MESSAGES TO
* FILE SOURCE.LOG OFF
* [NO]LIST(+) - GENERATE LIST FILE OFF
* [NO]CODE L+/L- LIST OBJECT CODE OFF
* [NO]CHECK T+/T- PERFORM RUNTIME CHECKS ON
* [NO]DEBUG D+/D-, P+/P-($) GENERATE DEBUG INFORMATION
* INCLUDING POST-MORTEM DUMP OFF
* [NO]COMPILE(+) - COMPILE THE FILE ON
* [NO]EXTERN E+/E-(@) ALL LEVEL-1 PROCEDURES
* AND FUNCTIONS MAY BE DE-
* CLARED AS "EXTERN" BY OTHER
* PROGRAMS. THESE ENTRIES MUST
* BE DEFINED IN THE PROGRAM
* HEADING ADDITIONALLY OFF
* [NO]CARD U+/U-(@) ONLY 72 CHARS OF THE SOURCE
* LINE ARE ACCEPTED (CARD FORMAT) OFF
* FORTIO I+/I- ENABLE FORTRAN-I/O IN EXTERNAL
* FORTRAN PROGRAMS OFF
* CODESIZE:N SN MAXIMUM NUMBER OF
* CODE WORDS FOR A BODY CIXMAX
* RUNCORE:N RN SIZE OF LOW-SEGMENT LOW-BREAK
* FILE:N FN THIS OPTION IS
* NECESSARY IF FILES ARE
* DECLARED IN EXTERNAL PROGRAMS.
* N IS THE NUMBER OF FILES
* ALREADY DECLARED IN THE MAIN
* (AND/OR OTHER EXTERNAL)
* PROGRAM(S) PLUS 1 0
* [NO]PROFILE C+/C- CROSS REFERENCE LIST WITH
* STATEMENT EXECUTION COUNTS FOR
* EACH BASIC BLOCK. OFF
* [NO]TTY Y+/Y- EXTERNAL PROCEDURES READ FROM TTY ON
* [NO]OUTPUT O+/O- EXT. PROCS. WRITE INTO OUTPUT ON
* [NO]CREF(+) - GENERATE CROSS REFERENCE LIST OFF
* [NO]LINK - CALL LINK-10 AFTER COMPILATION OFF
* [NO]EXECUTE - LOAD AND RUN COMPILED PROGRAM OFF
* REGISTER:N XN HIGHEST REGISTER USED
* TO PASS PARAMETERS STDPARREGCMAX
*
* SWITCHES MARKED WITH A (+) ARE ALSO PART OF THE DECSYSTEM-10 CONCISE COMMAND
* LANGUAGE. THE OTHERS MUST BE ENCLOSED IN "()" IF SPECIFIED
* IN A COMPILE-, LOAD-, EXECUTE- OR DEBUG-COMMAND-STRING,
* E.G.: COMPILE PASRL1=PASCAL.PAS(DEBUG/EXTERN)/LIST/COMPILE
*
* SWITCHES MARKED WITH ($) OR (@) MUST BE SPECIFIED FOR THE FIRST TIME BEFORE THE
* <PROGRAM HEADING>. THOSE WITH (@) CANNOT BE RE-DEFINED AGAIN INSIDE A <PROGRAM>,
* THOSE WITH ($) MIGHT BE RE-DEFINED INSIDE A <PROGRAM> OR
* <PROGRAM LIBRARY>. ALL OTHER SWITCHES CAN BE DEFINED AND
* RE-DEFINED ANYWHERE INSIDE A PROGRAM.
*
*******************************************************************************************)
(*NAMING CONVENTIONS*)
(********************************************************************************
*
* HINTS TO INTERPRET ABBREVIATIONS
*
* BRACK : BRACKET "[ ]" IX : INDEX
* C : CURRENT L : LOCAL
* C : COUNTER L : LEFT
* CST : CONSTANT PARENT : "( )"
* CTP : IDENTIFIER POINTER P/PTR : POINTER
* EL : ELEMENT P/PROC : PROCEDURE
* F : FORMAL R : RIGHT
* F : FIRST S : STRING
* F : FILE SY : SYMBOL
* F/FUNC : FUNCTION V : VARIABLE
* G : GLOBAL V : VALUE
* ID : IDENTIFIER BP : BYTEPOINTER
* REL : RELATIVE REL : RELOCATION
*
********************************************************************************)
(*IMPLEMENTATION: WHAT YOU NEED AND HOW YOU DO IT*)
(********************************************************************************
*
* FILES NECESSARY TO IMPLEMENT THE PASCAL COMPILER
* NOTE: THIS LIST HAS BEEN MODIFIED TO FIT LOTS COMPUTER FACILITY
*
* SOURCE-CODE
*
* PASCAL.PAS : PASCAL AND PASSGO COMPILERS
*
* LIBPAS.PAS : CCL (OPTION, GETOPTION, GETFILENAME, GETPARAMETER,
* ASKFILENAME, STARTFILE, GETNEXTCALL, REENTER)
* DDT (DEBUG)
* STATUS (GETSTATUS)
* READ (READIRANGE, READCRANGE, READRRANGE, READSCALAR,
* READISET, READCSET, READDSET)
* WRITE (WRTSCALAR, WRTISET, WRTDSET,WRTCSET)
* TIMING (SETRUNTIME, SETELAPSEDTIME, SETTIME,
* RUNTIME, ELAPSEDTIME, TIMEREPORT)
* STRLIB (CREATE, LENGTH, INDEX, SUBSTR, GETCHAR,
* PUTCHAR, COMPSTR, READSTR)
*
* LIBMAC.MAC : MACRO RUNTIME SUPPORT
*
* PCREF.PAS : CROSS REFERENCE WITHOUT CODE-GENERATION
*
* PFORM.PAS : PRETTYPRINTER (FORMATTER)
*
* OBJECT-CODE
*
* PASLIB.REL : SEARCH LIBRARY CONTAINING LIBPAS.REL
* AND LIBMAC.REL
*
*
* EXECUTABLE-CODE
*
* PASCAL.EXE : PASCAL EXECUTABLE MODULE
* PASSGO.EXE : PASSGO EXECUTABLE MODULE.
* PCREF.EXE : PCREF EXECUTABLE MODULE
* PFORM.EXE : PFORM EXECUTABLE MODULE.
*
*
* INFORMATION AND MAINTENANCE
*
* PASCAL.MAN : A GUIDE FOR THE LOTS PASCAL/PASSGO DIALECT
* PASCAL.HLP : A FAST REFERENCE GUIDE TO THE MAIN TOPICS OF THE MANUAL
* PASCAL.DOC : A DESCRIPTION OF SOME OF THE INSIDE PARTS OF THE COMPILER
*
*******************************************************************************)
(*******************************************************************************
*
* HOW TO GENERATE A NEW PASCAL COMPILER
* NOTE: THIS INFORMATION HAS BEEN UPDATED TO REFLECT THE
* SITUATION AT LOTS.
*
* 1) CHANGES TO THE RUNTIME-SUPPORT
*
* LET LIBPAS.PAS AND LIBMAC.MAC BE YOUR MODIFIED RUNTIME SUPPORT
*
* @COMPILE LIBMAC.MAC/LIST
* ...
* @COMPILE LIBPAS.PAS/LIST
* PASCAL: LIBPAS [CCL: OPTION, ... ] 1.. 2..
* ...
* PASCAL: LIBPAS [DEBUG: DEBUG] 2.. 3..
* ...
* EXIT
* @RENAME PASLIB.REL PASLIB.OLD
* @MAKLIB AT 10 SITES: ( $ IS <ALT MODE> )
* *PASLIB=LIBPAS,LIBMAC/APPEND .R FUDGE2
* *PASLIB=PASLIB/INDEX *PASLIB=LIBPAS,LIBMAC/A$
* *PASLIB=PASLIB/POINTS *PASLIB=PASLIB/X$
* *↑C *↑C
* @LOAD PASSGO (* BECAUSE PASLIB IS PART OF
* @SAVE PASSGO (* PASSGO.EXE
* @PRINT PASLIB.LST
*
*
* 2) CHANGES TO THE COMPILER
*
* LET PASCAL.PAS BE YOUR NEW COMPILER SOURCE
* (DO NOT FORGET TO CHANGE THE "HEADER" AND CHECK FOR THE CORRECT
* FILE DESCRIPTIONS FOR PASLIB AND PCREF IN INITPROCEDURE
* "SEARCH LIBRARIES")
*
* @PASCAL
* OBJECT = P1/EXECUTE
* LIST = <CR>
* SOURCE = PASCAL/VERSION:1
* PASCAL: P1 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* LINK: LOADING
* [...P1 EXECUTION]
* OBJECT= P2/EXECUTE
* LIST= <CR>
* SOURCE= PASCAL/VERSION:1
* PASCAL: P2 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* LINK: LOADING
* [...P2 EXECUTION]
* OBJECT= P3
* LIST= <CR>
* SOURCE= PASCAL/VERSION:1
* PASCAL: P3 [PASCAL] 1..
* 0 ERROR(S) DETECTED
* ...
* EXIT
* @ FILCOM AT SAIL: (MAYBE OTHER 10 SITES?)
* *TTY:=P2.REL,P3.REL .R BINCOM
* NO DIFFERENCES ENCOUNTERED P2
* *↑C P3
* @DELETE P1.*,P3.*
* @RENAME P2.* PASCAL
* @RENAME PASCAL.PAS PASCAL.OLD
* @RENAME PASCAL.NEW PASCAL.PAS
* @LOAD PASCAL/MAP
* @SAVE PASCAL
* @START
* OBJECT = PASSGO
* LIST = <CR>
* SOURCE = PASCAL/VERSION:2/NOTTY
* PASCAL: PASSGO [PASSGO] 1..
* 0 ERROR(S) DETECTED
* ...
* EXIT
* @LOAD PASSGO/MAP
* @SAVE PASSGO
* @PCREF
* OLDSOURCE = PASCAL.PAS
* CROSSLIST = PASCAL.LST/CROSS:1
* PCREF: PASCAL [PASCAL] 1..
* 0 ERROR(S) DETECTED
* EXIT
* @PCREF
* OLDSOURCE = PASCAL.PAS
* CROSSLIST = PASC2.LST/VERSION:1/CROSS:14
* PCREF: PASCAL [PASCAL] 1..
* 0 ERROR(S) DETECTED
* EXIT
* @PCREF
* OLDSOURCE = PASCAL.PAS
* CROSSLIST = PASSGO.LST/CROSS:14/VERSION:2
* PCREF: PASCAL [PASSGO] 1..
* 0 ERROR(S) DETECTED
* EXIT
* @PRINT PASCAL.CRL,PASC2.CRL,PASSGO.CRL/DELETE
*
*
* 3) CHANGES TO PCREF
*
* @LOAD PCREF/LIST/COMPILE
* ...
* EXIT
* @SAVE PCREF
*
* 4) CHANGES TO PFORM
*
* @LOAD PFORM/LIST/COMPILE
* ...
* EXIT
* @SAVE PFORM
*
********************************************************************************)
(*LIMITATIONS*)
(*******************************************************************************
*
* KNOWN BUGS AND RESTRICTIONS
*
* 1) IF THE DEVICE-PARAMETER FOR RESET/REWRITE IS NOT
* DEFAULTED, NEW BUFFERS ARE ALLOCATED WITHOUT REGARD
* TO THE FACT THAT THE NEW DEVICE COULD BE THE SAME AS THE
* THE OLD DEVICE.
*
* 2) COMPARISON OF VARIABLES OF TYPE PACKED RECORD OR
* PACKED ARRAY MAY CAUSE TROUBLE IF THESE VARIABLES APPEAR
* IN A VARIANT PART OR WERE ASSIGNED FROM A VARIANT PART
*
* 3) TOO LARGE ARRAY DIMENSIONS (F.E. MININT..MAXINT) CAUSE
* ARITHMETIC OVERFLOW INSTEAD OF AN APPROPRIATE ERROR
* MESSAGE
*
* 4) ARRAYS OF FILE AND RECORDS WITH FILES AS COMPONENTS
* ARE NOT IMPLEMENTED
*
* 5) SEGMENTED FILES ARE NOT IMPLEMENTED
*
* 6) CALL OF EXTERNAL COBOL OR ALGOL PROCEDURES IS
* NOT IMPLEMENTED
*
*
********************************************************************************)
(*MAINTENANCE INFORMATION*)
(********************************************************************************
*
* WHAT TO DO TO ADD PROCEDURES TO THE LIBRARY
*
* WHEN YOU ADD ANY PROCEDURE OR FUNCTION TO THE LIBRARY, YOU
* NEED TO DO THE FOLLOWING, FOR THE COMPILER TO KNOW ABOUT IT:
*
* 1. A) IF IT IS A PREDECLARED PROCEDURE OR FUNCTION:
* A1. IN INITPROCEDURE (*STANDARD NAMES :
* ADD ITS NAME TO NA[DECLPROC] OR NA[DECLFUNC]
* INCREMENT THE VALUE OF NAMAX[DECLPROC] OR NAMAX[DECLFUNC]
* A2. IN INITPROCEDURE (*PROCEDURE/FUNCTION NAMES :
* ADD THE ENTRYPOINT NAME (THE FIRST SIX CHARACTERS
* OF THE NAME OF THE PROCEDURE OR FUNCTION) TO
* EXTNA[DECLPROC] OR EXTNA[DECLFUNC]. DEFINE THE
* CORRESPONDING ELEMENT OF EXTLANGUAGE ACCORDINGLY.
*
* B) IF IT IS A RUNTIME SUPPORT PROCEDURE:
* B1. ADD A NEW MEMBER TO THE TYPE SUPPORTS, AT THE END
* B2. IN INITPROCEDURE (*RUNTIME-, DEBUG-SUPPORT NAMES :
* AD THE ENTRYPOINT NAME TO RUNTIME_SUPPORT.NAME
* (IF IT IS PART OF THE SUPPORTS FOR READ/WRITE, YOU
* NEED TO ADD AN ELEMENT TO TYPE SCALARFORM, OR CHANGE
* THE BOUNDS OF SUBSCRIPTS OF WRITE_SUPPORT, READ_SUPPORT,
* AND ADD THE CORRESPONDING VALUE FROM SUPPORTS TO
* THE CORRESPONDING ARRAY, IN THIS INITPROCEDURE)
*
* 2. PASSGO NEEDS TO KNOW THEIR LINKAGE ADDRESS, SO YOU NEED TO
* ADD THEIR ENTRYPOINT NAMES TO THE TABLES IN THE MACRO RUNTIME
* SUPORT PUTADR. THE PARAMETERS TO PUTADR ARE :
* EXTADDR[DECLPROC],EXTADDR[DECLFUNC],RUNTIME_SUPPORT.LINK
*
* 3. FOR PREDECLARED PROCEDURES/FUNCTIONS, YOU NEED TO ENTER THEN
* IN THE SYMBOL TABLE. ADD CODE AT THE END OF PROCEDURE
* ENTERSTDNAMES. FOLLOW THE MODEL GIVEN BY THE OTHER PROCEDURES:
* A) CALL ENTERSTDPARAMETER ONCE FOR EACH PARAMETER, STARTING
* WITH THE LAST. THE PARAETERS ARE: TYPE POINTER, FORMAL/ACTUAL
* (I.E., DECLARED AS VAR, YES/NO),A POINTER, EXPECTED
* POSITION. YHE POINTER SHOULD BE NIL IN THE FIRST CALL,
* CP IN ALL THE OTHERS. THE POSITION HAS TO BE FIGURED:
* THE FIRST PARAMETER (THE LAST CALL) GETS 1; FROM THEN ON,
* YOU INCREMENT IT BY THE NUMBER OF WORDS OCCUPIED BY
* EACH PARAMETER: ONE FOR SIMPLE TYPES AND FORMAL PARAMETERS
* AND POINTERS, TWO FOR PACKED ARRAYS OF CHAR OF LENGHT
* 6 TO 10, WHICH ARE ACTUAL PARAMETERS, ETC.
* B) CALL ENTERSTDPROCFUNC. PARAMETERS ARE: THE VALUE OF THE
* SECOND SUBSCRIPT OF ITS NAME IN ARRAY NA, PROC OR FUNC
* ACCORDING TO WHETHER THE FIRST SUBSCRIPT IS DECLPROC OR
* DECLFUNC, TYPE POINTER FOR WHAT IT RETURNS (NIL FOR
* PROCEDURES), AND CP.
*
* 4. IF THEY NEED SPECIAL TREATMENT FOR THE PARAMETER CHECKING,
* THAT IS, IF THEY TAKE DEFAULTS, ACCEPT SEVERAL TYPES FOR
* A GIVEN PARAMETER, OR HAVE OPTIONAL PARAMETERS (LIKE READ
* OR WRITE), YOU HAVE TO MAKE A PROCEDURE TO PARSE THEIR
* PARAMETERS WHEN CALLED. THAT IS DONE BY PROCEDURE CALL,
* INSIDE STATEMENT, AND THE PROCEDURES THAT ARE ALREADY THERE
* SHOULD SERVE YOU WELL AS EXAMPLES OF HOW TO DO IT.
*
********************************************************************************)
(*THE SYMBOL TABLE DATA STRUCTURE*)
(********************************************************************************
*
* DESCRIPTION OF THE DATA STRUCTURE THAT MAINTAINS THE SYMBOL TABLE IN THE
* PASCAL AND PASSGO COMPILERS FOR DEC-10,DEC-20, LOTS AND HAMBURG VERSIONS.
*
* ARMANDO R. RODRIGUEZ.
* 8-JUL-79
*
* ABSTRACT - INTRODUCTION
*
* THE SYMBOL TABLE IS FORMED WITH FIVE BASIC ELEMENTS: CONSTANT DESCRIPTOR
* BLOCKS, VALUE DESCRIPTOR BLOCKS, IDENTIFIER DESCRIPTOR BLOCKS (CTP↑),
* STRUCTURE (TYPE, MAINLY) DESCRIPTOR BLOCKS (STP↑) AND A MAIN FRAME, THAT
* KEEPS THE SYMBOL TABLE AND IMPLEMENTS THE SCOPING MECHANISM (DISPLAY).
* THE FIRST TWO ONES ARE EXTREMELY SIMPLE, AND WILL NOT BE DESCRIBED IN THIS
* DOCUMENT. THE OTHER THREE ONES CONTAIN MOST OF THE USEFUL IMFORMATION.
* A BRIEF GLOBAL DESCRIPTION OF EACH RECORD IS MADE, AND AN EXPLANATION OF
* THE MEANING AND USAGE OF EACH FIELD FOLLOWS, RETAINNG THE CASEING STRUCTURE
* OF THE RECORD. AN EXCCEPTION IS MADE IN THAT THE DUMMY FIELDS ARE ALL DES-
* CRIBED TOGETHER. WHEN IT SEEMS APPROPRIATE, AN EXPLANATION IS GIVEN ON THE
* MEANING AND PURPOSE OF EACH OF THE POSSIBLE VALUES OF A GIVEN FIELD.
* THE APPROACH IS NOT PURELY INFORMAL, BUT IT IS NOT ABSOLUTELY RIGUROUS.
* THE INTENTION IS TO BE RIGUROUS ENOUGH TO PREVENT AMBIGUITIES.
* COMMENTS AND CRITICISMS ON THIS DRAFT ARE WELCOME, ENCOURAGED AND APPRECIATED.
* (SEE ADDRESS INFORMATION IN THE LAST PAGE).
*
* EXPLANATION OF SOME TERMS:
*
* CHAIN: THE LINKER PROVIDES A FEATURE THAT THIS COMPILER TAKES GOOD ADVANTAGE
* OF: WHEN AN ADDRESS IS NEEDED THAT IS NOT KNOWN, A "PATCHBACK REQUEST"
* CAN BE ISSUED (INTERNALREQUEST, ITEM_10 IS USED FOR GOTOS AND CALLS TO FORWARD
* PROCEDURES, AND A SYMBOLS, ITEM_2, FOR EXTERNAL PROCEDURE AND RUNTIME CALLS).
* THE REQUEST PROVIDES THE ADDRESS OF THE INSTRUCTION THAT NEEDS IT AND IS
* SITUATED IN THE HIGHEST POSITION IN MEMORY. THERE, INSTEAD OF THE ADDRESS THAT
* WILL BE PATCHED BACK, THE ADDRESS OF THE NEXT HIGHEST REQUESTOR IS KEPT, SO
* FORMING A BACKWARDS (TOP-DOWN?) CHAIN OF REQUESTORS OF THE SAME ADDRESS. THE
* LAST ELEMENT OF THE CHAIN CONTAINS A ZERO (0). THE CURRENT TOP OF THAT CHAIN
* IS KEPT IN FIELD GOTO_CHAIN FOR LABELS, LINKCHAIN FOR PROCS/FUNCS, AND ...
* VECTORCHAIN FOR SCALARS. SINCE THE LINKER DOES NOT PARTICIPATE IN PASSGO RUNS,
* PASSGO DOES THA BACKPATCHING ITSELF WITH THE PROCEDURE WALKCHAIN, INSTEAD OF
* THE REQUEST MADE BY PASCAL USING THE PROCEDURE WRITE_PAIR.
*
* BAS¬ TYPE AND HOST TYPE: THIS IS THE TERMINOLOGY USED IN THE PROPOSED ISO
* STANDARD FOR PASCAL. BASE TYPE REFERS TO THE TYPE OF
* THE ELEMENTS OF A SET, AND HOST TYPE REFERS TO THE ORIGINAL TYPE FROM WHICH A
* CLOSED INTERVAL DEFINES A SUBRANGE TYPE.
*
* LEVEL AND SCOPE: AN IDENTIFIER DEFINED AT A GIVEN LEVEL IS ASSIGNED THAT LEVEL.
* ITS SCOPE IS ALL LEVELS WITH A NUMERICAL VALUE HIGHER THAN
* ITS OWN, THAT ARE NOT IN THE SCOPE OF ANOTHER IDENTIFIER WITH THE SAME NAME AND
* A LEVEL WITH A NUMERICAL VALUE HIGHER THAN ITS OWN. LEVEL 0 IS ASSIGNED TO PRE-
* DECLARED OBJECTS, LEVEL 1 TO GLOBAL OBJECTS (DECLARED IN THE MAIN BLOCK) AND
* LEVELS 2 AND UP TO THE LOCAL OBJECTS INSIDE PROCEDURES AND FUNCTIONS.
*
* THE STRUCTURE DESCRIPTOR BLOCK:
*
* ITS MAIN PURPOSE IS TO DESCRIBE A TYPE BY ITS STRUCTURE. NO NAMING IS
* MANAGED DIRECTLY BY THIS RECORD, ALTHOUGH IT WILL POINT TO IDENTIFIER
* DESCRIPTORS IN THE CASE OF DECLARED SCALARS AND FIELDS OF RECORDS.
* THE VALUES OF SCALKIND: TAGFWITHID, TAGFWITHOUTID AND VARIANT ARE USED TO
* DESCRIBE PARTS OF A RECORD STRUCTURE. ALL THE OTHER VALUES HAVE OBVIOUS
* MEANINGS. (POWER STANDS FOR POWERSET).
*
* STP: POINTER TO A STRUCTURE DESCRIPTOR RECORD
* STRUCTURE: STRUCTURE DESCRIPTOR RECORD.
* DB0, DB1, DB2, DB3, DB4, DB5, DB6, DB7, DB9: DUMMY FIELDS USED TO GET
* BETTER ADDRESSING IN THE OTHER FIELDS.
* SELFSTP: USED TO BUILD THE DEBUGGER TABLES: A COPY OF THIS RECORD, WITH
* THE POINTER VALUES CHANGED TO BE MEANINGFUL AT RUNTIME.
* SIZE: MEMORY SPACE NEEDED BY A VARIABLE OF THIS TYPE, IN WORDS.
* NOCODE: FLAG SET WHILE DUMPING THE DEBUGGING INFORMATION, TO PREVENT
* FROM DUMPING A RECORD TWICE.
* BITSIZE: MEMORY SPACE NEEDED, IN BITS, IF THIS TYPE IS USED TO BUILD A
* PACKED STRUCTURE. (IF SIZE > 1 WORD, BITSIZE = 1 WORD).
*
* FORM: FLAG TO DISTINGUISH THE DIFFERENT STRUCTURES. THE NAMES ARE OBVIOUS,
* AND BRIEFLY DESCRIBED BELOW.
*
* SCALAR: A SIMPLE TYPE, EXCEPT FOR SUBRANGES.
* SCALKIND: STANDARD: INTEGER, REAL OR ASCII (CHAR IS A SUBRANGE)
* DECLARED: NAMED SCALARS, INCLUDING BOOLEANS.
* FCONST: POINTER TO THE IDENTIFIER DESCRIPTOR FOR THE FIRST MEMBER
* OF THIS TYPE. THEY WILL BE CHAINED BY THEIR NEXT FIELD.
* VECTORADDR: ADDRESS OF THE STRING CONSTANT THAT CONTAINS ALL THE
* NAMES OF THE ELEMENTS, ORDERED FROM VALUE ZERO.
* VECTORCHAIN: TOP OF THE CHAIN OF REFERENCES TO VECTORADDR.
* SEE EXPLANATION ON CHAINS ABOVE.
* DIMENSION: ORD(LAST(THIS TYPE)): THE MAXIMUM VALUE THAT IS DEFINED
* BY A NAME IN THIS TYPE. IT IS ALSO THE NUMBER OF
* ELEMENTS MINUS ONE.
* NEXTSCALAR: ALL TYPE DESCRIPTORS THAT DESCRIBE DECLARED (NAMED)
* SCALARS ARE CHAINED THROUGH THIS FIELD, TO SIMPLIFY
* THE DUMP OF THEIR NAME STRINGS IN WRITE_MACHINE_CODE
* REQUEST: FLAG THAT SETS TRUE IF ANY FORMATTED I/O (READ/WRITE) IS
* DONE ON THIS TYPE, OR IT DEFINES A PARAMETER TO AN
* EXTERNAL PROCEDURE. USED TO DECIDE WHETHER TO DUMP
* THE STRING OF NAMES FOR RUNTIME USE.
* TLEV: THE SCOPING LEVEL AT WHICH THE TYPE WAS DEFINED.
*
* SUBRANGE: SUBRANGE TYPE. INCLUDES CHAR.
* RANGETYPE: POINTER TO THE STRUCTURE DESCRIPTOR OF THE HOST TYPE.
* VMIN, VMAX: MINIMUM AND MAXIMUM VALUES OF THE CLOSED RANGE THAT
* DEFINES THE SUBRANGE. (SUBRANGES OF REAL ARE SUPPOR-
* TED).
*
* POINTER: POINTER TYPE.
* ELTYPE: POINTER TO THE STRUCTURE DESCRIPTOR OF THE TYPE THIS TYPE
* WILL POINT TO.
*
* POWER: SET TYPE.
* ELSET: POINTER TO THE STRUCTURE DESCRIPTOR OF THE BASE TYPE.
*
* ARRAYS: ARRAY TYPE.
* ARRAYPF: "PACKED FLAG": TRUE IF THE ELEMENTS OF THIS ARRAY ARE PACKED
* ARRAYBPADDR: ADDRESS OF A WORD IN DATA AREA RESERVED FOR A BYTE POINTER
* USED FOR ADDRESSING ELEMENTS OF THIS ARRAY.
* AELTYPE: POINTER TO THE STRUCTURE DESCRIPTOR OF THE TYPE OF THE ELEMENT
* OF THIS ARRAY.
* INXTYPE: POINTER TO THE STRUCTURE DESCRIPTOR OF THE TYPE OF THE SUBS-
* CRIPT OF THIS ARRAY.
*
* RECORDS: RECORD TYPE.
* RECORDPF: "PACKED FLAG".
* FSTFLD: POINTER TO THE IDENTIFIER DESCRIPTOR OF THE FIRST FIELD OF THE
* NON-VARIANT PART OF THIS RECORD. THEY WILL BE CHAINED THROUGH
* THE NEXT FIELD.
* RECVAR: POINTER TO A STRUCTURE DESCRIPTOR OF FORM TAGFWITHID OR ...
* TAGFWITHOUTID, FROM WHICH THE DESCRIPTION OF THE VARIANT PART
* HANGS. NIL IF NO VARIANT PART.
*
* FILES: FILE TYPE.
* FILETYPE: POINTER TO THE STRUCTURE DESCRIPTOR OF THE TYPE OF THE
* ELEMENTS THAT FORM THE SEQUENCE IN THIS FILE, OR, IN OTHER
* WORDS, THE TYPE OF THE SO-CALLED FILE_BUFFER_VARIABLE.
* FILEFORM: BINARY VALUE USED BY RUNTIMES TO DISTINGUISH A FILE THAT WILL
* BE USED WITH FORMATTED I/O (TEXT_FILE) FROM ONE THAT NEEDS
* STANDARD I/O (DATA_FILE).
* FILEMODE: BINARY VALUE USED BY THE RUNTIMES TO DISTINGUISH A FILE THAT
* HAS BYTE-LONG ELEMENTS (TEXT, PACKED FILE OF ASCII) FROM
* ONE THAT HAS N-WORD-LONG ELEMENTS (ALL OTHER FILES).
*
* TAGFWITHID: A TAG FIELD THAT USES PHYSICAL MEMORY SPACE: POINTS TO
* THE ALTERANTIVE VARIANT PART DESCRIPTORS.
* TAGFWITHOUTID: SAME, FOR A TAG FIELD THAT DOES NOT USE MEMORY SPACE.
* FSTVAR: POINTER TO THE STRUCTURE DESCRIPTOR FOR ONE OF THE ALTERNATIVE
* VARIANT PARTS OF THIS RECORD AT THIS (CASING) LEVEL. NOTICE
* THAT THE LEXICAL LEVEL REMAINS THE SAME AS LONG AS THE TYPE
* OF A FIELD IS NOT A RECORD ITSELF, SO NESTED CASES ARE STILL
* AT THE SAME LEVEL. THE OTHER VARIANT ALTERNATIVES WILL BE
* CHAINED THROUGH THE NXTVAR FIELD.
* TAGFIELDP: POINTER TO THE IDENTIFIER DESCRIPTOR OF A TAGFWITHID.
* TAGFIELDTYPE: POINTER TO THE STRUCTURE DESCRIPTOR OF A TAGFWITHOUTID.
*
* VARIANT: THE STRUCTURE THAT IS 'ACTIVE' IN THE VARIANT PART OF A RECORD,
* WHEN THE CORRESPONDING TAG FIELD HAS SOME GIVEN VALUE.
* NXTVAR: POINTER TO THE STRUCTURE DESCRIPTOR OF THE VARIANT PART FOR
* SOME OTHER VALUE OF THE TAG FIELD.
* SUBVAR: POINTER TO THE STRUCTURE DESCRIPTOR OF A TAGFWITHID OR OF A
* TAGFWITHOUTID THAT DESCRIBES A VARIANT PART CONTAINED IN THIS
* VARIANT PART, IF ANY. (E.G., IN THIS RECORD TYPE, STRUCTURE,
* THE VARIANT DESCRIPTOR FOR FORM = SCALAR POINTS THROUGH SUBVAR
* TO THE TAGFWITHID DESCRIPTOR FOR SCALKIND).
* FIRSTFIELD: POINTER TO THE IDENTIFIER DESCRIPTOR OF THE FIRST FIELD OF
* THIS VARIANT PART.
* VARVAL: VALUE THAT THE TAG FIELD SHOULD HAVE FOR THIS VARIANT TO BE
* 'ACTIVE'. (VALID/CURRENT).
*
* THE IDENTIFIER DESCRIPTOR BLOCK:
*
* ITS MAIN PURPOSE IS TO DESCRIBE THE MEANING AND PROPERTIES OF AN IDENTIFIER.
* NO STRUCTURAL INFORMATION IS REFLECTED DIRECTLY IN THIS RECORD, EXCEPT FOR THE
* FACT THAT DECLARED SCALARS, PARAMETER LISTS AND FIELDS ARE DESCRIBED BY A CHAIN
* OF IDENTIFIER DESCRIPTORS. THE NAMES USED IN THE MAIN VARIANT PART HAVE OBVIOUS
* MEANINGS.
*
* CTP: POINTER TO AN IDENTIFIER DESCRIPTOR RECORD.
*
* IDENTIFIER: IDENTIFIER DESCRIPTOR RECORD.
* VDUMMY1, VDUMMY2, HDUMMY, PDUMMY: DUMMY FIELDS USED TO GET BETTER ADDRESSING
* IN THE REST OF THE FIELDS.
* NAME: OF THE IDENTIFIER.
* LLINK, RLINK: TO KEEP THE IDENTIFIERS OF EACH LEVEL (SCOPE) ORGANIZED IN A
* BINARY SEARCH TREE, BY NAME.
* IDTYPE: POINTER TO THE STRUCTURE DESCRIPTOR OF THE TYPE OF THIS CONSTANT,
* VARIABLE, FIELD OR FUNCTION. NIL OTHERWISE.
* NEXT: USED TO FORM CHAINS OF IDENTIFIERS. DEPENDING ON KLASS, IT POINTS TO:
* IN KONST: (WHEN IT IS A MEMBER OF A DECLARED TYPE): THE MEMBER OF THE
* TYPE WITH THE INTERNAL VALUE IMMEDIATELY LOWER THAN THIS ONE.
* IN VARS: (WHEN THEY DESCRIBE A PARAMETER OF A PROCEDURE):
* THE NEXT PARAMETER.
* IN FIELD: NEXT FIELD OF THIS STATIC OR VARIANT PART OF THIS RECORD TYPE.
* IN PROC AND FUNC: (WHEN THEY ARE ACTUAL): THE FIRST PARAMETER.
* IN LABELS: NEXT LABEL THAT WAS DECLARED AT THIS SAME SCOPE LEVEL.
* (THIS CHAINS ARE COMPLEMENTARY. ALL IDENTIFIERS HANG FROM RLINK, LLINK).
* SELFCTP: USED TO BUILD THE DEBUGGER TABLES: A COPY OF THIS RECORD, WITH THE
* POINTER VALUES CHANGED TO BE MEANINGFUL AT RUNTIME.
* NOCODE: FLAG SET WHILE DUMPING THE DEBUGGING INFORMATION, TO PREVENT FROM
* DUMPING A RECORD TWICE.
*
* KLASS: FLAG TO DISTINGUISH THE DIFFERENT KINDS OF IDENTIFIERS. THE NAMES ARE
* OBVIOUS, AND ARE BRIEFLY EXPLAINED BELOW.
*
* KONST: A CONSTANT. (EITHER A NAME THAT DEFINES A NUMBER, AS DECLARED IN THE
* CONST PART OF A PROGRAM, OR AN ELEMENT OF A DECLARED SCALAR TYPE)
* VALUES: ITS NUMERICAL VALUE.
*
* VARS: A VARIABLE. (EITHER A PARAMETER OR A LOCAL VARIABLE).
* VKIND: ACTUAL: LOCAL VARIABLE OR VALUE PARAMETER.
* FORMAL: VAR PARAMETER.
* VLEV: THE LEVEL (SCOPE) AT WHICH IT WAS DECLARED.
* CHANNEL: FOR VARIABLES THAT ARE FILES, THE ACTUAL HARDWARE CHANNEL NUMBER
* THAT WILL BE REQUESTED FOR IT AT RUNTIME.
* VADDR: ADDRESS OF THE PLACE IN MEMORY THAT WAS ASSIGNED TO IT. FOR LOCAL
* VARIABLES AND PARAMETERS, IT IS RELATIVE TO THE BASE OF THE STACK
* FRAME (POINTED TO BY ACREGISTER 16B). [2]
*
* FIELD: A FIELD OF A RECORD (EITHER IN A STATIC OR A VARIANT PART.)
* PACKF: "PACKED" FLAG: (IT SHOULD BE CALLED ALIGNMENT FLAG): INFORMATION
* ON THE LOCATION OF ITS STARTING ADDRESS: EITHER AT A WORD BOUN-
* DARY, OR AT A HALF-WORD BOUNDARY, OR AT SOME BIT POSITION INSIDE
* THE WORD, WHICH REQUIRES A BYTE POINTER TO ACCESS IT.
* NOTPACK,HWORDR,HWORDL: FLDADDR: ADDRESS OF THE FIELD, RELATIVE TO THE
* ADDRESS OF THE RECORD.
* PACKK: FLDBYTE: A DESCRIPTOR OF THE BYTEPOINTER USED TO REACH THIS FIELD.
*
* PROC, FUNC: A PROCEDURE OR FUNCTION (EITHER THE PROC/FUNC ITSELF, OR AN
* EXTERN OR FORWARD REFERENCE, OR A PROC/FUNC DECLARED AS A
* PARAMETER).
* PFDECLKIND: DISTINCTION BETWEEN STANDARD AND DECLARED. (NOTE: THIS IS
* NOT THE PASCAL LANGUAGE MEANING OF STANDARD AND DECLARED/PREDE-
* CLARED.)
* STANDARD: IT NEEDS SPECIAL PARSING, EITHER BECAUSE IT IS DECOMPO-
* SED INTO CALLS TO DIFFERENT RUNTIMES(READ/WRITE) OR BECAUSE IT
* TAKES NON-STANDARD PARAMETER LISTS (GET,PUT,BREAK,...) OR
* BECAUSE IT IS COMPILED INLINE (PACK/UNPACK, ABS,...).
* KEY: SUBSCRIPT FOR ITS NAME IN NA (STDFUNC OR STDPROC)
* DECLARED: IT HAS NO SPECIAL TREATMENT, SO A CALL TO IT WILL BE
* TREATED BY THE CALL_NON_STANDARD PROCEDURE.
* PFLEV: LEVEL AT WHICH IT WAS DECLARED.
* PARLISTSIZE: AMOUNT OF MEMORY SPACE NEEDED IN THE STACK FRAME FOR
* THE PARAMETERS.
* PFADDR: ADDRESS OF THE ENTRY POINT, FOR A LOCAL PROCEDURE.
* HIGHEST_REGISTER: HIGHEST REGISTER USED FOR PARAMETER PASSING.
* USUALLY 6. SEE THE DESCRIPTION OF THE /REGISTER:N SWITCH, OR
* $XN OPTION [1]. SEE ALSO [2]
* PFKIND: FLAG TO DISTINGUISH PARAMETER PROCEDURES.
* ACTUAL: NOT A PARAMETER PROCEDURE.
* FORWDECL: FLAG. TRUE IF IT WAS DECLARED FORWARD AND THE
* BODY HAS NOT BEEN COMPILED YET.
* EXTERNDECL: TRUE IF IT WAS DECLARED EXTERNAL OR IF IT IS A
* PREDECLARED PROCEDURE FROM THE RUNTIME LIBRARY.
* ACTIVATED: TRUE WHILE PARSING INSIDE THE SCOPE OF THIS FUN-
* CTION, SO THAT ITS APPEARENCE IN THE LEFT SIDE
* OF AN ASSIGNMENT IS LEGAL.
* PFCHAIN: TO KEEP THREE CHAINS OF IDENTIFIER DESCRIPTORS:
* ONE FOR LOCAL, ONE FOR FORWARD REFERENCES, AND
* ONE FOR EXTERNAL REFERENCES, FOR ?, FOR INTER-
* NAL REQUESTS, AND FOR SYMBOL REQUESTS, RESPEC-
* TIVELY.
* LANGUAGE: EITHER PASCALSY OR FORTRANSY, TO APPLY THE DIFFE-
* RENT LINKAGE CONVENTIONS.
* TESTFWDPTR: CHAIN OF FORWARD PROCEDURES DECLARED AT THIS
* SCOPE. FOR TEST ON UNSATISFIED FORWARD DECLA-
* RATIONS.
* EXTERNALNAME: TO BE USED IN THE SYMBOLS REQUEST TO THE
* LINKER.
*
* LINKCHAIN: TOP OF THE CHAIN OF REFERENCES (CALLS) TO THIS
* PROCEDURE/FUNCTION. SEE EXPLANATION ON CHAINS
* ABOVE.
* FORMAL: A PARAMETER PROCEDURE/FUNCTION.
* FPARAM: POINER TO THE IDENTIFIER DESCRIPTOR OF THE FIRST
* PARAMETER TO THIS PROCEDURE. NOTE THAT THESE
* DESCRIPTORS HAVE NO NAME, AND ARE NOT INSERTED
* IN THE BINARY TREE. [1]. (IN ACTUAL PROCEDURES/
* FUNCTIONS, IT IS KEPT IN NEXT, BUT HERE NEXT
* POINTS TO THE NEXT OF THE PARAMETERLIST IN WHICH
* THIS PROCEDURE IS A MEMBER.)
*
* LABELS: A DECLARED LABEL.
* SCOPE: LEVEL AT WHICH IT WAS DECLARED, WHICH DEFINES ITS SCOPE.
* JUMP_INDEX: SUBSCRIPT INTO JUMP_TABLE, WHICH KEEPS THE ADDRESS WHERE
* THE ACREGISTERS 16B AND 17B (STACK FRAME BOUNDARIES)
* ARE SAVED ON ENTRY. USED FOR GOTOS OUT OF BLOCK.
* EXIT_JUMP: TRUE IF THIS LABEL IS THE SUBJECT OF A GOTO OUT OF BLOCK.
* GOTO_CHAIN: TOP OF THE CHAIN OF REFERENCES TO THIS LABEL. SEE
* EXPLANATION ON CHAINS ABOVE.
* LABEL_ADDRESS: THE ADDRESS IN MEMORY WHERE A GOTO TO THIS LABEL SHOULD
* JUMP TO.
*
* THE DISPLAY ARRAY:
*
* THE ARRAY VARIABLE DISPLAY IS THE MECHANISM THAT IMPLEMENTS THE SCOPING RULES
* OF PASCAL: THE MOST IMPORTANT COMPONENT OF EACH OF ITS ELEMENTS IS THE CTP
* FNAME WHICH POINTS TO THE IDENTIFIER DESCRIPTOR OF THE FIRST NAME THAT WAS
* DECLARED IN THAT SCOPE. THE REST OF THEM HANG FROM IT IN A BINARY SEARCH TREE.
* WHILE PARSING THE DECLARATION OF A RECORD TYPE, AND WHEN INSIDE A WITH STATE-
* MENT, THE CHAIN OF FIELDS OF THAT RECORD HANG FROM ONE OF THE ELEMENTS OF
* DISPLAY. THE INDEX IN DISPLAY MATCHES EXACTLY THE SCOPE LEVEL FOR ALL OTHER
* CASES. DISPLAY[0].FNAME POINTS TO THE BINARY TREE OF PREDEFINED OBJECTS, AND
* SO ON. WHEN THE PARSING OF THE BODY OF A PROCEDURE IS FINISHED, THE WHOLE
* BINARY TREE THAT DESCRIBES IT IS THROWN AWAY. THE DESCRIPTORS OF ITS PARAMETERS
* ARE STILL AROUND, THOUGH, HANGING FROM THE NEXT FIELD.
*
********************************************************************************)
(*LINKAGE CONVENTIONS*)
(********************************************************************************
*
* LINKAGE CONVENTIONS OF THE PASCAL AND PASSGO COMPILERS FOR DEC-SYSTEM10
* AND DEC-SYSTEM20, HAMBURG AND LOTS VERSIONS
* VERSION 1.0
*
* ARMANDO R. RODRIGUEZ
* 6-AUG-79
*
* ABSTRACT:
* A SEMIFORMAL DESCRIPTION OF THE MEMORY AND ACREGISTER MAPPING MECHANISM
* IS GIVEN, TOGETHER WITH A DESCRIPTION OF THE LINKAGE CONVENTION AND THE
* FRAME SETUP SEQUENCE, FOR CODE GENERATED BY THE DEC10-DEC20 PASCAL
* COMPILERS. COMMENTS ARE ADDED IN SOME PLACES, TO CLARIFY THINGS FOR
* THE READER WHO PLANS TO WRITE A ROUTINE IN ASSEMBLY LANGUAGE, AND
* CALL IT FROM PASCAL PROGRAMS.
*
* ACKNOWLEDGEMENTS:
* THANKS TO POLLE ZELLWEGER AND DAN HALBERT, WHO POINTED OUT FLAWS IN THE
* FIRST DRAFT, AND HELPED GETTING IDEAS STRAIGHT FOR THIS ONE.
*
* NOTATION:
* A) ALL THE REFERENCES TO ACREGISTERS ARE OCTAL NUMBERS. THE LETTER B
* AFTER THE NUMBER MEANS OCTAL.
* B) FOR RELATIVE ADDRESSES, ASSEMBLY LANGUAGE NOTATION IS USED:
* 1(17B) MEANS (CONTENTS OF RIGHT HALF OF 17B) PLUS ONE.
*
* 0. ACREGISTER MAPPING:
* ACREGISTER 17B POINTS TO THE TOP OF THE STACK.
* ACREGISTER 16B POINTS TO THE BOTTOM OF THE CURRENT STACK FRAME
* (THE TOP OF THE STACK FOR THE CALLER, PLUS ONE)
* ACREGISTER 15B POINTS TO THE 'TOP' OF THE HEAP (THE HEAP GROWS
* DOWN FROM THE TOP OF THE LOW SEGMENT TOWARDS THE STACK.)
* ACREGISTERS 7 TO 14B ARE USED AS AN UPSIDE-DOWN STACK TO KEEP
* WITH POINTERS (THAT IS, IT GROWS FROM 14B TOWARDS 7).
* INSIDE PASCAL CODE, THE EXPRESSION EVALUATION STACK GROWS FROM
* ACREGISTER 2 TOWARDS THE WITH STACK. (IF IT RUNS OUT OF
* REGISTERS, PASCAL GIVES A COMPILE TIME ERROR. IT DOES
* STACK HEIGHT REDUCTION, SO THIS RARELY HAPPENS).
* ACREGISTERS 2 TO 6 WILL PARTICIPATE IN THE PARAMETER PASSING.
* (THE VALUE 6 IS THE DEFAULT VALUE FOR THE SWITCH /REGISTER
* OR COMPILER OPTION (*$XN+). SEE THE MANUAL[1] FOR DETAILS)
* IF THERE IS A NONEMPTY EXPRESSION EVALUATION STACK (WHEN
* CALLING A FUNCTION TO EVALUATE A PARAMETER, ONLY) THEN
* IT IS SAVED AND RESTORED BY THE CALLER.
* ACREGISTERS 0 AND 1 ARE NEVER USED BY PASCAL-GENERATED CODE:
* THEY ARE KEPT FREE, FOR THE USE OF THE RUNTIME ROUTINES. IF
* YOU ARE WRITTING AN ASSEMBLY-LANGUAGE ROUTINE, AND YOU DON'T
* CALL ANY RUNTIME LIBRARY ROUTINE, YOU ARE FREE TO USE THEM.
*
* 1. BUT, WHERE IS THE DISPLAY KEPT?
* THE DISPLAY IS NOT KEPT AS AN ENTITY. THE DYNAMIC LINK IS CARRIED
* AROUND BY THE LEFT HALF OF ACREGISTER 16B, AND DEPOSITED IN THE LAST
* WORD OF THE CALLER'S FRAME, IN THE LEFT HALF ALSO. THIS WORD WAS
* ALLOCATED BY THE CALLER FOR THAT SPECIFIC PURPOSE. SO, TO GET THE
* BASE OF THE FRAME FOR THE CALLER OF YOUR CALLER (TWO LEVELS), YOU
* USE THE LEFT HALF OF -1(16B), PUT IT IN ACREGISTER X, AND THEN USE
* THE LEFT HALF OF -1(X).
*
* 2. THINGS DONE BY THE CALLER ON CALL:
* A) SAVE ANY LIVE REGISTERS IN THE RANGE 2 TO 6, IN TEMPORARY SPACE
* IN ITS OWN AREA, AND FROM THE RANGE 14B DOWN TO 7, IN THE
* LOCATION OF THE CORRESPONDING POINTER VARIABLE.
* B) PASS THE PARAMETERS (SEE 3 BELOW).
* C) ISUE A PUSHJ 17B,<CALLEE> TO CALL.
*
* 3. PASSING PARAMETERS:
* A) ACREGISTERS 2 TO 6 ARE USED FOR THE FIRST PARAMETERS.
* B) VAR PARAMETERS:
* THE ADDRESS IS PASSED. THE CALLEE WILL ACCESS THEM INDIRECTLY.
* C) NON-VAR PARAMETERS, ONE- AND TWO-WORD LONG:
* THE VALUE IS PASSED IN THE ACREGISTERS. IF IT IS A TWO-WORD,
* AND THE FIRST WORD FALLS IN ACREGISTER 6, IT IS PUT THERE, AND
* THE SECOND WORD GOES TO ITS TARGET PLACE BEYOND THE STACK.
* D) NON-VAR PARAMETERS, LARGER THAN TWO WORDS:
* THE ADDRESS IS PASSED IN AN ACREGISTER.
* E) WHEN THE SIX ACREGISTERS HAVE BEEN USED UP:
* WHAT WOULD HAVE BEEN PASSED THROUGH THE ACREGISTER IS
* PUT DIRECTLY IN ITS PLACE IN MEMORY BEYOND THE TOP OF THE STACK.
*
* 4. MEMORY MAPPING OF THE CALLEE'S AREA:
* STARTING IN THE BASE ADDRESS (CONTENTS OF 16B WHEN IN YOUR AREA,
* CONTENTS OF 17B PLUS 1, WHEN BEYOND THE STACK):
* FOR PROCEDURES: 1(BASE) HAS THE FIRST PARAMETER. PARAMETERS ARE
* ASSIGNED MEMORY IN THE ORDER IN WHICH THEY WERE DECLARED.
* FOR FUNCTIONS: 1(BASE) IS WHERE THE RETURNED VALUE WILL BE PUT.
* 2(BASE) HAS THE FIRST PARAMETER. EVERYTHING ELSE IS THE SAME.
* LOCAL VARIABLES COME AFTER THE PARAMETERS, ALMOST IN THE ORDER OF
* DECLARATION. (A GROUP OF VARIABLES DECLARED BY AN ID-LIST
* IS ALLOCATED IN REVERSE ORDER).
* ANY TEMPORARY SAVE AREAS ARE ALLOCATED AFTER THE LOCAL VARIABLES.
* THEY ARE USED AS A COMPILE-TIME-ASSIGNED STACK, AND THE
* HIGHEST LEVEL IS ALLOCATED.
* AN EXTRA WORD IS ALLOCATED FOR THE DYNAMIC LINK.
*
* 5. FIRST THINGS DONE BY THE CALLEE:
* A) REORGANIZE ACREGISTERS 16B AND 17B TO POINT TO ITS OWN FRAME.
* B) UPDATE THE DYNAMIC LINK BY MOVING AROUND HALFS BETWEEN 17B,
* 16B AND -1(16B).
* B) COPY THE PARAMETERS FROM THE ACREGISTERS INTO THEIR PLACES IN MEMORY.
* + VALUE (NON-VAR) PARAMETERS WHICH ARE LONGER THAN TWO
* WORDS: TAKE THE ADDRESS FROM THE ACREGISTER, OR FROM THE
* FIRST WORD IN ITS MEMORY LOCATION (IF IT IS AN OVERFLOW
* PARAMETER), AND DO A BLT (BLOCK TRANSFER).
* + VAR PARAMETERS, AND NON-VAR WHICH ARE ONE OR TWO WORDS:
* IF THEY ARE IN ACREGISTERS, COPY THEM INTO THEIR PLACE IN
* MEMORY. IF NOT, DO NOTHING.
*
* 6. REGISTERS THAT THE CALLEE CAN USE:
* ALL OF REGISTERS 2 TO 14B. ANY OF THEM THAT WERE ALIVE WERE SAVED BY THE
* CALLER. IF YOU DON'T CALL ANY OF THE RUNTIME LIBRARY ROUTINES, YOU CAN
* USE REGISTERS 0 AND 1 ALSO.
*
* 7. LAST THINGS DONE BY THE CALLEE:
* A) PUT BACK IN PLACE THE LEFT HALFS OF ACREGISTERS 17 (PUSHJ COUNT)
* AND 16B (DYNAMIC LINK).
* B) ISUE A POPJ 17B TO GO BACK.
* C) NOTHING ELSE. EVEN IF IT IS A FUNCTION, THE RESULT WAS PUT IN ITS
* PLACE IF AND WHEN AN ASSIGNMENT WAS MADE TO THE FUNCTION
* IDENTIFIER. (ITS PLACE IS 1(16B), OR 1(17B) IF YOU DID NOT
* BUILD YOUR OWN FRAME).
*
* 8. THINGS DONE BY THE CALLER ON RETURN:
* A) RECONSTRUCT ITS OWN FRAME.
* B) IF IT SAVED ACREGISTERS IN MEMORY, BRING THEM BACK TO PLACE.
* B) IF THE CALLEE WAS A FUNCTION, PICK UP THE RESULT FROM 2(17),
* AND PUT IT IN AN ACREGISTER (THE CURRENT TOP OF THE EXPRESSION
* EVALUATION STACK).
*
* BIBLIOGRAPHY:
*
* [1] RODRIGUEZ, ARMANDO: PASCAL AND PASSGO AT LOTS, ADAPTED FROM
* PASCAL FOR THE DECSYSTEM-20, BY E. KISICKI AND H.H.NAGEL.
* AVAILABLE ON-LINE AT LOTS AND SCORE IN DOC:PASCAL.MAN
* ACCESSIBLE AT SU-AI BY .READ PASMAN
*
*
********************************************************************************)
(*PACKING POLICY*)
(********************************************************************************
*
* PACKING POLICY OF THE PASCAL AND PASSGO COMPILERS FOR DECSYSTEM-10
* AND DECSYSTEM-20, LOTS AND HAMBURG VERSIONS.
*
* ARMANDO R. RODRIGUEZ.
* 10-JUL-79
*
* INTRODUCTION:
*
* THE STANDARD ONLY SAYS THAT THE USE OF THE RESERVED WORD PACKED IN A TYPE DEFI-
* NITION IS AN INDICATION TO THE COMPILER THAT IT SHOULD USE A PACKING MECHANISM,
* BUT IT DOES NOT DEFINE THE MECHANISM, AN IT IMPLIES THAT ONE WAY OF DOING IT IS
* BY DOING NOTHING. PASCAL/PASSGO DO HAVE A MECHANISM, THAT TRIES TO PROVIDE BOTH
* A REASONABLE PACKED SPACE AND THE LEAST POSSIBLE LOSS IN ADDRESSING EFFICIENCY,
* BY PREVENTING POTENTIALLY LARGE (ONE-WORD LONG OR MORE) OBJECTS FROM GETTING
* ALIGNED TO A BIT ADDRESS, AND BY TAKING ADVANTAGE OF THE HALF-WORD ADDRESSING
* MECHANISM OF THE DEC-10 HARDWARE.
*
* POLICY:
*
* THE ORDER OF DEFINITION OF THIS RULES IS INTENDED FOR CLARITY ONLY. IT DOES
* NOT IMPLY ANY PRECEDENCE RULE. THE RULES SHOULD BE MUTUALLY EXCLUSIVE. IF
* THERE IS ANY AMBIGUITY, IT IS A BUG IN THIS DOCUMENT: PLEASE TELL ARR.
*
* 1. EVERY NEW VARIABLE IS ALIGNED AT A NEW WORD BOUNDARY.
*
* 2. EVERY ARRAY OR RECORD, EVEN IF IT IS AN ELEMENT OF A PACKED ARRAY OR A FIELD
* OF A PACKED RECORD, IS ALIGNED AT A NEW WORD BOUNDARY AND HAS A SIZE
* GIVEN IN FULL WORDS, REGERDLESS OF WHETHER IT ITSELF IS PACKED.
*
* 4. PACKED FILES OF ASCII OR OF A SUBRANGE OF ASCII (E.G., CHAR) ARE ACTUALLY
* ACCESSED AT BYTE BOUNDARIES. PACKED HAS NO EFFECT ON FILES OF ANY OTHER
* TYPE, THAT IS, GETS AND PUTS WILL MOVE AROUND FULL WORDS.
*
* 5. IN FIELDS OF RECORDS AND ELEMENTS OF ARRAYS, EXCEPT FOR THE PREVIOUS RULES:
* A. POINTERS ARE KEPT IN HALF A WORD.
* C. WHEN THE SIZE OF AN OBJECT IS LARGER THAN WHAT IS LEFT OF THIS WORD,
* THE OBJECT IS ALIGNED TO THE NEXT WORD.
* D. WHEN THE TYPE OF AN OBJECT IS A SUBRANGE OF INTEGER, BUT ITS LOWER BOUND
* IS NEGATIVE, ITS SIZE IS A FULL WORD, AND IT IS ALLIGNED TO THE NEXT
* WORD BOUNDARY.
* E. ALL OTHER CASES ARE PACKED TO THE EXACT NUMBER OF BITS THAT THEY NEED,
* AND ALLIGNED IN THE NEXT AVAILABLE BIT. (BOOLEAN USES 1 BIT, ASCII AND
* ITS SUBRANGES, 1 BYTE, THAT IS, 7 BITS).
*
*
* THINGS THAT YOU CAN DO:
*
* THERE ARE THINGS THAT THE COMPILER WILL NOT DO, THAT YOU CAN DO FAIRLY EASILY,
* BY USING THE APPROPRIATE DUMMY FIELDS TO FORCE AN ALIGNMENT THAT WOULD GIVE
* YOU BETTER ADDRESSING AT RUNTIME:
*
* A. WHEN THE SIZE OF AN OBJECT IS EXACTLY HALF A WORD (18 BITS), THE COMPILER
* WILL NOT DO ANYTHING SPECIAL, BUT IF IT ALSO HAPPENS TO BE ALIGNED AT
* A HALF-WORD BOUNDARY, HALF-WORD ADDRESSING AND MOVING WILL BE USED.
*
* B. WHEN YOU NEED THE ELEMENTS OF ONE RECORD TO MAP ALL INTO ONE ONLY WORD,
* YOU HAVE TO DO TWO THINGS: (A) (OBVIOUSLY) MAKE SURE THAT THE TOTAL
* SUM OF THE BIT SPACE NEEDED IS 36 OR LESS, AND (B) MAKE SURE THAT NONE
* OF THE TYPES OF THE FIELDS IS AN ARRAY OR RECORD: EVEN IF IT IS PACKED,
* IT WILL ALOCATE A FULL WORD FOR ITSELF, AND ALIGN AT A NEW WORD BOUN-
* DARY.
********************************************************************************)
(* GLOBAL DECLARATIONS. *)
%13
PROGRAM pascal; (* 14.*) \
%24
PROGRAM PASSGO; (* 15.*) \
LABEL
0;
CONST
(* NIL = 377777B; *)
(* ALFALENGTH = 10; *)
(* MININT = 400000000000B; *)
(* MAXINT = 377777777777B; *)
(* MAXREAL = 1.7014118432E+38; *)
(* SMALLREAL= 1.4693680107E-39; *)
(* INF = 0; UNLESS STRINGPACK IS FALSE - 25.*)
%1 HEADER = 'PASCAL/LOTS 1.1 6-SEP-79'; (* 14.*) \
%2 HEADER = 'PASSGO/LOTS 1.1 6-SEP-79'; (* 15.*) \
%3 header = 'PASCAL/SAIL 1.1 6-SEP-79'; \
%4 HEADER = 'PASSGO/SAIL 1.1 6-SEP-79'; \
headlen = 11; (*PART OF THE HEADER THAT WIL SHOW UP IN TTY*)
(*COMPILER PARAMETERS:*)
(**********************)
displimit = 20; (* MAXIMUM DECLARATION-SCOPE NESTING *)
%13 max_file = 12; (* MAXIMUM NUMBER OF USER-DECLARED FILES *) (* 14.*) \
max_channel = 15; (* HIGHEST DATA-CHANNEL ASSIGNED TO A FILE *)
maxlevel = 10; (* MAXIMUM PROC/FUNC LEVEL *)
strglgth = 135; (* MAXIMUM LENGTH FOR STRING-CONSTANT *) (* 25. INCREASED FROM 120.*)
xtrastrglgth = 136; (* 25. FOR PARAMETERS TO STRING PROCEDURE CALLS.*)
sizeoffileblock = 21; (* SIZE OF FILE CONTROL-BLOCK *)
cixmax = 1000; (* STANDARD SIZE OF CODE-ARRAY *)
maxerr = 4; (* MAXIMUM OF ERRORS IN 1 SOURCE-LINE *)
labmax = 9999; (* MAXIMUM VALUE OF A PROGRAM LABEL *)
bitmax = 36; (* NR. OF BITS OF 1 DECSYSTEM-10 MACHINE-WORD *)
hwcstmax = 377777B; (* MAXIMUM POS. INTEGER IN HALFWORD *)
entrymax = 20; (* MAXIMUM ENTRIES INTO EXTERN PROGRAM *)
extpfmax = 29; (* MAXIMUM OF EXTERN STANDARD PROC/FUNC *) (* 25. *)
stdmax = 36; (* NR. OF STANDARD NAMES *)
rswmax = 42; (* NR. OF RESERVED WORDS *)
rswmaxp1 = 43; (* RESERVED WORDS PLUS 1 *)
stdchcntmax = 132; (* MAXIMUM OF CHARS IN SOURCE-LINE *)
basemax = 71; (* MAXIMUM VALUE OF A SET ELEMENT *)
offset = 40B; (* USED FOR SETS OF CHARACTERS *)
buffer_size = 200B; (* DECSYSTEM-10 DISK-BUFFER SIZE *)
tagfmax = 5; (* MAX. NR. OF VARIANTS ALLOWED IN CALL OF "NEW" *)
%12
jump_max = 50; (* MAX. NR. OF LABEL DECLARATIONS *)
\
%34
jump_max = 150; (* MAX. NR. OF LABEL DECLARATIONS *)
\
maxpcrefoption = 18; (* 4. NR. OF OPTION SWITCHES OF PCREF *)
reg0 = 0; (* WORKREGISTER *)
reg1 = 1; (* WORKREGISTER (USED FOR ARRAY-BYTEPOINTERS) *)
regin = 1; (* TO INITIALIZE REGC *)
stdparregcmax = 6; (* HIGHEST REGISTER USED FOR PARAMETERS *)
within = 12; (* FIRST REGISTER FOR WITH-STACK *)
newreg = 13; (* LAST PLACE OF NEW-STACK *)
basis = 14; (* ADDR OF CURRENT ACTIVATION-REC, STATIC AND DYNAMIC LINK *)
topp = 15; (* FIRST FREE WORD IN DATA-STACK *)
jbrel = 44B; (* LOCATION OF (0,HIGHEST LEGAL LOW-SEG ADDRESS) *)
jbsa = 120B; (* LOCATION OF (1ST UNUSED LOW-SEG ADDRESS,START-ADDRESS OF PROGRAM) *)
(* JBFF = 121B; (* LOCATION OF (0,POINTER BEHIND LAST FILE-BUFFER) *) (* NOT USED.*)
jbapr = 125B; (* LOCATION OF (0,PC AFTER PROGRAM ERROR) *)
jbddt = 74B; (* LOCATION OF (LAST PASDDT-ADDR, PASDDT-ADDR + 2) *)
tty_sixbit = 646471B; (* SIXBIT REPR. FOR 'TTY ' *)
dsk_sixbit = 446353B; (* SIXBIT REPR. FOR 'DSK ' *)
ascii_mode = 0; (* (SYSTEM-) FLAGS FOR ASCII-MODE *)
binary_mode = 14B; (* (SYSTEM-) FLAGS FOR BINARY-MODE *)
text_file = 0; (* (PASCAL-) FLAGS FOR "PACKED FILE OF (SUBRANGE OF) CHAR" = "TEXT" *)
data_file = 1; (* (PASCAL-) FLAGS FOR OTHER FILES *)
debug_save = 0B; (* ADDR OF DEBUG-SYSTEM STACK *)
debug_stop = 1B; (* PUSHJ INTO DEBUG ON "STOP" *)
(* DEBUG_PAGEHEAD = 2B; (* START OF "STOP"-CHAIN *) (* NOT USED.*)
debug_stackbottom = 3B; (* 1ST WORD OF PROGRAM-STACK *)
debug_initialization = 6B; (* PUSHJ INTO DEBUG-INITIALIZATION *)
debug_programname = 7B; (* ADDR OF ADDR OF PROGRAMNAME *)
system_low_start = 140B; (* LOC 0B..137B CONTAIN SYSTEM-INFO. *)
(* SYSTEM_HIGH_START = 400010B; (* LOC 400000B..400007B CONTAIN SYSTEM-INFO. *) (* NOT USED.*)
low_start = 10B; (* LOC 0B..7B RESERVED FOR DEBUG-PROGR. *)
high_start = 400000B; (* START OF EXECUTABLE CODE *)
maxaddr = 777777B; (* HIGHEST LEGAL ADDRESS *)
%13 (* 18. NO LINK_ITEMS IN PASSGO.*)
item_1 = 1; (* LINK ITEM 1: CODE *)
item_2 = 2; (* LINK ITEM 2: SYMBOLS *)
item_3 = 3; (* LINK ITEM 3: HIGHSEG *)
item_4 = 4; (* LINK ITEM 4: ENTRIES *)
item_5 = 5; (* LINK ITEM 5: LOW-/ HIGHSEGMENT BREAK *)
item_6 = 6; (* LINK ITEM 6: PROGRAM NAME *)
item_7 = 7; (* LINK ITEM 7: START ADDRESS *)
item_10 = 10B; (* LINK ITEM 10: INTERNAL REQUESTS *)
item_17 = 17B; (* LINK ITEM 17: LINK LIBRARIES *)
(* 18.*) \
entry_symbol = 0; (* ENTRY SYMBOL FLAG *)
global_symbol = 1; (* GLOBAL SYMBOL FLAG *)
local_symbol = 2; (* LOCAL SYMBOL FLAG *)
sixbit_symbol = 6; (* SIXBIT SYMBOL FLAG *)
extern_symbol = 14B; (* EXTERN SYMBOL FLAG *)
%24 MAXFILECODE = 1777B; (* 20. SIZE OF MEMORY FOR USER FILE BLOCKS AND STRING CONSTANTS.*)
%24 MAXCODE = 60000B; (* 20. SIZE OF MEMORY FOR USER PROGRAM AND FILE BLOCKS.*) \
stringpack = true; (* 25. IF FALSE, NON-STANDARD STRING PACKAGE IS DEACTIVATED.*)
TYPE
(* INTEGER = MININT..MAXINT *)
(* REAL = -MAXREAL..MAXREAL *)
(* CHAR = ' '..'_' *)
(* ASCII = NUL..DEL *)
(* BOOLEAN = (FALSE,TRUE) *)
(* TEXT = PACKED FILE OF CHAR *)
(* ALFA = PACKED ARRAY[1..ALFALENGTH] OF CHAR *)
(*DESCRIBING:*)
(*************)
(*BASIC SYMBOLS*)
(***************)
symbol = (ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
lparent,rparent,lbrack,rbrack,comma,semicolon,period,arrow,
colon,becomes,labelsy,constsy,typesy,varsy,functionsy,
proceduresy,packedsy,setsy,arraysy,recordsy,filesy,forwardsy,
beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,loopsy,
gotosy,exitsy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
externsy,pascalsy,fortransy,programsy, thensy,othersy,initprocsy,segmentsy,otherssy);
operator = (noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,
ltop,leop,geop,gtop,neop,eqop,inop);
setofsys = SET OF symbol;
(*BASIC RANGE DEFINITIONS*)
(*************************)
levrange = 0..maxlevel;
keyrange = 0..77B;
fileformrange = 0..77B;
filemoderange = 0..77B;
addrrange = 0..maxaddr;
instrange = 0..677B;
radixrange = 0..37777777777B;
flagrange = 0..17B;
bitrange = 0..bitmax;
acrange = 0..15;
ibrange = 0..1;
coderange = 0..hwcstmax;
bits5 = 0..37B;
bits6 = 0..77B;
bits7 = 0..177B;
bits12 = 0..7777B;
bits18 = 0..777777B;
setrange = 0..basemax;
jump_range = 1..jump_max;
(*CONSTANTS*)
(***********)
bpointer = PACKED RECORD
sbits,pbits: bitrange;
ibit,dummybit: ibrange;
ireg: acrange;
reladdr: addrrange
END;
cstclass = (int,reel,pset,strd,strg,bptr);
csp = ↑ constnt;
constnt = RECORD
selfcsp: csp; nocode: boolean;
CASE cclass: cstclass OF
int : (intval: integer;
intval1:integer (*TO ACCESS SECOND WORD OF PVAL*) );
reel: (rval: real);
pset: (pval: SET OF setrange);
strd,
strg: (slgth: 0..strglgth;
sval: PACKED ARRAY [1..strglgth] OF char);
bptr: (byte: bpointer)
END;
valu = RECORD
CASE integer OF
1: (ival: integer);
2: (valp: csp);
3: (byte: bpointer)
END;
(*DATA STRUCTURES*)
(*****************)
structform = (scalar,subrange,pointer,power,arrays,records,files,tagfwithid,tagfwithoutid,variant);
declkind = (standard,declared);
stp = ↑structure;
ctp = ↑identifier;
(*SEE THE DOCUMENTATION AT FRONT FOR A DETAILED DESCRIPTION OF THE FIELDS
IN THIS RECORD*)
structure = PACKED RECORD
selfstp: stp; size: addrrange;
nocode: boolean; bitsize: bitrange;
CASE form: structform OF
scalar: (CASE scalkind: declkind OF
declared: (db0: bits6; fconst: ctp;
vectoraddr, vectorchain: addrrange;
dimension: integer; nextscalar: stp;
request: boolean; tlev: levrange));
subrange: (db1: bits7; rangetype: stp; vmin, vmax: valu);
pointer: (db2: bits7; eltype: stp);
power: (db3: bits7; elset: stp);
arrays: (arraypf: boolean; db4: bits6; arraybpaddr: addrrange;
aeltype, inxtype: stp);
records: (recordpf: boolean; db5: bits6;
fstfld: ctp; recvar: stp);
files: (db6: bits6; filepf: boolean; filtype: stp;
file_form: fileformrange; file_mode: filemoderange);
tagfwithid,
tagfwithoutid: (db7: bits7; fstvar: stp;
CASE boolean OF
true : (tagfieldp: ctp);
false: (tagfieldtype: stp));
variant: (db9: bits7; nxtvar, subvar: stp; firstfield: ctp; varval: valu)
END;
btp = ↑bytepoint;
bytepoint = PACKED RECORD
last: btp;
arraysp: stp;
bitsize: bitrange
END;
gtp = ↑globptr;
globptr = RECORD
nextglobptr: gtp ;
firstglob,
lastglob : addrrange ;
fcix : coderange
END ;
ftp = ↑filblck;
filblck = PACKED RECORD
nextftp : ftp ;
fileident : ctp
END ;
ptp = ↑programparameter;
programparameter = PACKED RECORD
nextptp: ptp;
fileidptr: ctp;
fileid: alfa;
inputfile: boolean
END;
(*NAMES*)
(*******)
scalarform = (integerform,charform,realform,boolform,declaredform);
idclass = (types,konst,vars,field,proc,func,labels);
setofids = SET OF idclass;
idkind = (actual,formal);
packkind = (notpack,packk,hwordr,hwordl);
(*SEE THE DOCUMENTATION AT FRONT FOR A DETAILED DESCRIPTION OF THE FIELDS
IN THIS RECORD*)
identifier = PACKED RECORD
name: alfa;
llink, rlink: ctp;
idtype: stp; next: ctp;
selfctp: ctp; nocode: boolean;
CASE klass: idclass OF
konst: (values: valu);
vars: (vkind: idkind;
vlev: levrange;
channel: acrange;
vdummy1: bits5;
vdummy2: bits18;
vaddr: addrrange);
field: (CASE packf: packkind OF
notpack,
hwordl,
hwordr: (hdummy: bits12; fldaddr: addrrange);
packk: (pdummy: bits12; fldbyte: bpointer));
proc,
func: (CASE pfdeckind: declkind OF
standard: (key: keyrange);
declared: (pflev: levrange;
parlistsize,pfaddr: addrrange;
highest_register: acrange;
CASE pfkind: idkind OF
actual: (forwdecl: boolean;
externdecl: boolean;
activated: boolean;
pfchain:ctp;
language: symbol;
testfwdptr: ctp;
externalname: alfa;
linkchain: PACKED ARRAY[levrange] OF addrrange);
formal: (fparam:ctp)));
labels:(scope: levrange;
jump_index: 0..jump_max;
exit_jump: boolean;
goto_chain: addrrange;
label_address: addrrange)
END;
disprange = 0..displimit;
where = (blck (* ID IS VARIABLE ID*)
,crec (* ID IS FIELD ID OF RECORD WITH CONSTANT ADDRESS*)
,vrec (* ID IS FIELD ID OF RECORD WITH VARIABLE ADDRESS*)
);
(*RELOCATION*)
(************)
coderefs = (noref,constref,externref,forwardref,gotoref,pointref,noinstr,saveref,debugref);
relbyte = (no,right,left,both);
relword = PACKED ARRAY[0..17] OF relbyte;
supports = ( stackoverflow, errorinassignment, indexerror, overflow, inputerror,
errorinset, nocoreavailable,
allocate, free,
exitprogram, runprogram, readpgmparameter,
resetfile, rewritefile, opentty, fortranreset, fortranexit, closefile,
getcharacter, getfile, getline, putfile, putline, putpage, putbuffer,
initializedebug, enterdebug, loaddebug,
convertintegertoreal,
asciitime, asciidate,
readreal, readinteger, readcharacter, readstring, readpackedstring,
writecharacter, writedefcharacter,
writestring, writedefstring,
writepackedstring, writedefpackedstring,
writeboolean, writedefboolean,
writereal, writedef1real, writedef2real,
writeinteger, writedefinteger,
writehexadecimal, writedefhexadecimal,
writeoctal, writedefoctal,
readirange, readcrange, readrrange,
readscalar,
readiset, readcset, readdset,
wrtscalar,
wrtiset, wrtcset, wrtdset,
startclock, showruntime, badpointer, (* 12. 21.*)
readpseudostring, (* 25.*)
writepseudostring,writedefpseudostring, (* 25.*)
dumpcounts); (* 28.*)
(*EXPRESSIONS*)
(*************)
attrkind = (cst,varbl,expr);
attr = RECORD
typtr: stp;
CASE kind: attrkind OF
cst: (cval: valu);
varbl: (packfg: packkind;
indexr: acrange;
indbit: ibrange;
vlevel: levrange;
bpaddr,dplmt: addrrange;
vrelbyte: relbyte;
subkind: stp;
vclass: idclass;
vbyte: bpointer);
expr: (reg:acrange)
END;
testp = ↑ testpointer;
testpointer = PACKED RECORD
elt1,elt2: stp;
lasttestp: testp
END;
(*OTHER TYPES:*)
(**************)
lineandpage = RECORD (* 28. KEEPS INFO FOR STATEMENT COUNTS*)
line, page: addrrange;
END;
cntarray = ARRAY[1..100] OF lineandpage;
%24
CNTP = ↑CNTBLOCK;
CNTBLOCK = PACKED RECORD
NEXT : CNTP;
LINEINFO: CNTARRAY;
END;
\
write_form = (write_entry,write_name,write_hiseg,write_globals,write_code,write_internals,write_library,
write_debug,write_fileblocks,write_symbols,write_start,write_end,write_counters); (* 28.*)
namekind = (stdconst,stdfile,stdproc,stdfunc,declproc,declfunc);
btpkind = (unused,requested,calculated,used);
kindofmsg = (intmsg,alfamsg);
etp = ↑ errorwithtext;
errorwithtext = PACKED RECORD
number: integer;
next: etp;
CASE msgkind: kindofmsg OF
intmsg: (intval: integer);
alfamsg: (string: alfa);
END;
ksp = ↑ konstrec;
konstrec = PACKED RECORD
addr, kaddr: addrrange;
constptr: csp;
nextkonst: ksp;
double_chain: boolean
END;
pdp10instr = PACKED RECORD
instr : instrange ;
ac : acrange;
indbit : ibrange;
inxreg : acrange;
address : addrrange
END ;
change_form=(intcst,pdp10code,realcst,strcst,sixbitcst,halfwd,pdp10bp,radix) ;
charword = PACKED ARRAY[1..5] OF char;
halfs = PACKED RECORD
lefthalf: addrrange;
righthalf: addrrange
END;
codepointer = ↑codearray;
codearray = RECORD
CASE change_form OF
pdp10code: (instruction: ARRAY[coderange] OF pdp10instr);
intcst: (word: ARRAY[coderange] OF integer);
halfwd: (halfword: ARRAY[coderange] OF halfs)
END;
relpointer = ↑relarray;
relarray = PACKED ARRAY[coderange] OF relbyte;
refpointer = ↑refarray;
refarray = PACKED ARRAY[coderange] OF coderefs;
bufferpointer = ↑commandbuffer;
commandbuffer = PACKED ARRAY[0..buffer_size] OF ascii;
pageelem = PACKED RECORD
word1: pdp10instr;
lhalf: addrrange; rhalf: addrrange
END;
debentry = RECORD
lastpageelem: pageelem;
globalidtree: addrrange;
standardidtree: addrrange;
intpoint: stp;
realpoint: stp;
boolpoint: stp;
charpoint: stp
END;
nlk = ↑newlinks;
newlinks = PACKED RECORD
reftype : stp;
refadr : addrrange;
next : nlk;
END;
%24 (* 19. NEEDED FOR PUTADR.*)
SUPPORTADDRARRAY = PACKED ARRAY [SUPPORTS] OF ADDRRANGE;
EXTADDRVECTOR = PACKED ARRAY [1..EXTPFMAX] OF ADDRRANGE;
EXTADDRARRAY = PACKED ARRAY [DECLPROC..DECLFUNC] OF EXTADDRVECTOR;
(* 19.*) \
(* 25. FOR COMPILER-GENERATED PARAMETERS FOR THE SSTRING PROCEDURES.*)
sstrptr = ↑sstringparlength;
sstringparlength = PACKED RECORD
count: 0..2;
value: ARRAY[1..2] OF 1..xtrastrglgth;
next: sstrptr;
END;
(*------------------------------------------------------------------------------*)
VAR
%24 (* 18.*)
USERPROG: RECORD (* EXECUTABLE CODE OF THE USER PROGRAM.*)
CASE INTEGER OF
1: (EXECODE: ARRAY [0..MAXCODE] OF INTEGER);
2: (EXEHALFS: ARRAY [0..MAXCODE] OF HALFS);
END;
(* USERPROG SHOULD ALWAYS BE THE FIRST DECLARED VARIABLE.*)
(* 18.*) \
(*VALUES RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:*)
(*****************************************************)
sy: symbol; (*LAST SYMBOL*)
op: operator; (*CLASSIFICATION OF LAST SYMBOL*)
val: valu; (*VALUE OF LAST CONSTANT*)
lgth: integer; (*LENGTH OF LAST STRING CONSTANT*)
id: alfa; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)
OR LAST INTEGER CONST (FOR LABEL PROCESSING)*)
ch: char; (*LAST CHARACTER*)
(*COUNTERS:*)
(***********)
i, j: integer;
entries: integer;
support_index: supports;
%13 language_index: symbol; (* 17.*) \
chcntmax: 0..stdchcntmax;
chcnt: 0..stdchcntmax; (*CHARACTER COUNTER*)
tchcnt: integer;
symcnt: integer; (* 30. TO GIVE EXTRA ADVICE ON ERROR ON THE FIRST TOKEN OF A LINE*)
codeend, (*FIRST LOCATION NOT USED FOR INSTRUCTIONS*)
%24 USERAREASTART, (* 20. FIRST LOCATION USED FOR FILE DESCRIPTOR BLOCKS *)
%24 DATASTART, (* 20. FIRST LOCATION USED FOR USER PROGRAM DATA *)
%24 FILELC, (* 20. DATA LOCATION FOR FILE DESCRIPTOR BLOCKS.*) \
lcmain, lc,ic: addrrange; (*DATA LOCATION AND INSTRUCTION COUNTER*)
%13 program_count: integer; (* 14.*) \
%24 EXECODECOUNT: INTEGER; (* 18.*) \
(*SWITCHES:*)
(***********)
dp, (*DECLARATION PART*)
reset_possible, (*TO IGNORE SWITCHES WHICH MUST NOT BE RESET*)
search_error, (*TO ALLOW FORWARD REFERENCES IN POINTER TYPE
DECLARATION BY SUPPRESSING ERROR MESSAGE*)
%13 external, (*IF TRUE, ALL LEVEL-1 PROC/FUNC MAY BE
DECLARED AS "EXTERN" BY OTHER PROGRAMS*) (* 14.*) \
ttyread, (*TO INHIBIT TTYOPEN ('*'-PROMPTING) IF NO TTY-INPUT REQUESTED*)
outputwrite, (* 13. TO INHIBIT REWRITE OF OUTPUT IF NOT USED*)
inputpar, (* 13. TO INHIBIT RESET OF INPUT IF IT IS A PROGRAM PARAMETER.*)
outputpar, (* 13. SAME FOR OUTPUT.*)
debug, (*ENABLE DEBUGGING*)
debug_switch, (*TO GENERATE DEBUG INFORMATION*)
%13 list_code, (*LIST MACRO CODE*) (* 14.*) \
lptfile, (*TO INHIBIT GENERATION OF LIST-FILE*)
logfile, (*TO SEND TO A LOG FILE A COPY OF THE TTY MESSAGES*)
initglobals, (*INITIALIZE GLOBAL VARIABLES*)
loadnoptr, (*IF TRUE, NO POINTERVARIABLE SHALL BE LOADED*)
%13 fortran_enviroment, (* 14.*) \
%13 loadit, (* 14.*) \
%13 load_and_go, (* 14.*) \
cross_reference, (*IF TRUE, PCREF SHOULD BE CALLED AT THE END*)
counting, (*TRUE IF STATEMENT COUNTS (PROFILE) ARE REQUIRED*)
resettty, (*IF FALSE, EXTERNAL PROCEDURES ARE NOT EXPECTED TO INPUT FROM TTY*)
openoutput, (*IF FALSE, EXTERNAL CALLS DO NOT EXPECT TO WRITE TO OUTPUT*)
runtime_check, (*IF TRUE, PERFORM RUNTIME-TESTS*)
genprocfile, (*TRUE IF /PRC WAS SET, TO GIVE PROCEDURE LINE INFO*)
incondcomp, (*TRUE WHEN INSIDE A CONDITIONALLY-COMPILED PART*) (* 8.*)
hassoslines, (* TRUE IF THE SOURCE FILE HAS SOS LINES*)
parsingparameters, (* 25. TRUE WHEN CALL_NON_STANDARD IS PARSING THE PARAMETERS.*)
recall, (* 25. FOR COMPTYPES TO AVOID COUNTING TWICE WHEN RECURSING.*)
first_symbol: boolean; (* TRUE BEFORE THE FIRST SYMBOL IN THE PROGRAM IS PARSED*)
(*POINTERS:*)
(***********)
sexternpfptr,
localpfptr, externpfptr: ctp; (*PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN*)
parmptr: ptp; (*PTR TO PROGRAMPARM.-CHAIN*)
stdfileptr: ARRAY[1..4] OF ctp; (*PTRS TO STD-FILES*)
sstringptr, strgrngptr, (* 25. PREDEFINED STRING AND 1..135 TYPES *)
strgrng0ptr, (* 25. PREDEFINED TYPE 0..135 *)
packc135ptr, (* 25. FOR THE TYPE OF STRTEXT IN STRING.*)
packc1ptr, (* 25. TO CONVERT CHARACTERS TO STRING CONSTANTS.*)
packc0ptr, (* 25. FOR THE CONSTANT NULLSTR.*)
alfaptr,packc9ptr,
packc3ptr,packc5ptr,asciiptr,
packc6ptr,packc8ptr,
intptr,realptr,charptr,
boolptr,nilptr,textptr: stp; (*POINTERS TO ENTRIES OF STANDARD IDS*)
sdeclscalptr,
declscalptr: stp; (*PTR TO CHAIN OF DECLARED SCALARS*)
utypptr,ucstptr,uvarptr,
ufldptr,uprcptr,ufctptr, (*POINTERS TO ENTRIES FOR UNDECLARED IDS*)
forward_pointer_type: ctp; (*HEAD OF CHAIN OF FORW DECL TYPE IDS*)
errmptr, errmptr1: etp; (*TO CHAIN ERRORS WITH TEXT*)
last_label: ctp; (*TOP OF LABEL CHAIN*)
slastbtp,
lastbtp: btp; (*HEAD OF BYTEPOINTERTABLE*)
sfileptr,
fileptr: ftp;
firstkonst: ksp;
anyfileptr: stp; (*TO ALLOW FILES OF "ANY" TYPE AS
VAR PARAMETERS IN STAND. PROC/FUNC*)
fglobptr,cglobptr : gtp ; (*POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD*)
globtestp : testp ; (*POINTER TO LAST PAIR OF POINTERTYPES*)
globnewlink : nlk ; (*POINTER TO NEW-LINKS*)
(*BOOKKEEPING OF DECLARATION LEVELS:*)
(************************************)
currname: alfa; (* 27.NAME OF THE CURRENT PROCEDURE/FUNCTION*)
level: levrange; (*CURRENT STATIC LEVEL*)
disx, (*LEVEL OF LAST ID SEARCHED BY SEARCHID*)
top: disprange; (*TOP OF DISPLAY*)
display: ARRAY[disprange] OF
PACKED RECORD
fname: ctp;
CASE occur: where OF
crec: (clev: levrange;
cindr: acrange;
cindb: ibrange;
crelbyte: relbyte;
cdspl,
clc : addrrange)
END;
(*ERROR MESSAGES:*)
(*****************)
errorflag: boolean; (*TRUE IF SYNTACTIC ERRORS DETECTED IN ONE PROGRAM*)
no_code_gen: boolean; (*IF TRUE, WRITE_MACHINE_CODE WILL NOT EXECUTE*)
(*SET BY ANY ERRORS OR BY /NOLOAD IN PASSGO*)
needsaneoln: boolean;
errorinfirst: boolean; (* 30. TRUE IF THE EXTRA ADVICE MESSAGE IS NEEDED*)
errinx: 0..maxerr ; (*NR OF ERRORS IN CURRENT SOURCE LINE*)
errorcount: integer; (*TOTAL NR OF ERRORS DETECTED IN PROGRAM*)
errorexit: boolean; (*TO ENABLE EXIT DURING COMPILATION*)
overrun: boolean;
errlist:
ARRAY [1..maxerr] OF
PACKED RECORD
arw: 1..maxerr;
pos: 1..stdchcntmax;
nmr: 1..600;
tic: char
END;
errmess15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF char;
errmess20 : ARRAY [1..15] OF PACKED ARRAY [1..20] OF char;
errmess25 : ARRAY [1..18] OF PACKED ARRAY [1..25] OF char;
errmess30 : ARRAY [1..21] OF PACKED ARRAY [1..30] OF char;
errmess35 : ARRAY [1..17] OF PACKED ARRAY [1..35] OF char;
errmess40 : ARRAY [1..13] OF PACKED ARRAY [1..40] OF char;
errmess45 : ARRAY [1..20] OF PACKED ARRAY [1..45] OF char;
errmess50 : ARRAY [1..10] OF PACKED ARRAY [1..50] OF char;
errmess55 : ARRAY [1.. 8] OF PACKED ARRAY [1..55] OF char;
errorinlast,
errorinline,
followerror : boolean;
lastchcnt: 0..stdchcntmax;
lastbuffer,
errline,
buffer: ARRAY [1..stdchcntmax] OF char;
line500, (* TO GIVE LINE NUMBER IN THE TTY EVERY 500 LINES OF A PAGE*)
firstpage, (* 6. PAGE AT WHICH THE PROGRAM STARTS. *)
pagecnt,
linecnt: integer;
linenr: PACKED ARRAY [1..5] OF char;
(*EXPRESSION COMPILATION:*)
(*************************)
gattr: attr; (*DESCRIBES THE EXPR CURRENTLY COMPILED*)
aos: (b0,b1,b2,b3,aosinstr,sosinstr); (*TESTS CONDITION FOR AOS/SOS-INSTRUCTION*)
leftside: attr; (*LEFT SIDE OF ASSIGNMENT*)
(*COMPILATION OF PACKED STRUCTURES:*)
(***********************************)
arraybps: ARRAY[1:18] OF
RECORD
abyte: bpointer; bytemax: bitrange;
address: addrrange;
state: btpkind
END;
(*DEBUG-SYSTEM:*)
(***************)
laststop: addrrange; (*LAST BREAKPOINT*)
lastline, (*LINENUMBER FOR BREAKPOINTS*)
linediff, (*DIFFERENCE BETWEEN ↑ AND LINECNT*)
lastpage:integer; (*LAST PAGE THAT CONTAINS A STOP*)
pageheadadr, (*OVERGIVE TO DEBUG.PAS*)
lastpager: addrrange; (*POINTS AT LAST PAGERECORD*)
pager: pageelem; (*ACTUAL PAGERECORD*)
debentry_size: integer; (*DEBENTRY LENGTH *)
debugentry: debentry;
idrecsize: ARRAY[idclass] OF integer;
strecsize: ARRAY[structform] OF integer;
(*STRUCTURED CONSTANTS:*)
(***********************)
lettersordigits,letters,digits,identchars,hexadigits: SET OF char;
constbegsys,simptypebegsys,typebegsys,blockbegsys,selectsys,facbegsys,
languagesys,statbegsys,typedels: setofsys;
rw: ARRAY [1..rswmax] OF alfa;
frw: ARRAY [1..11(*ALFALENGTH+1*)] OF 1..rswmaxp1;
rsy: ARRAY [1..rswmax] OF symbol;
ssy: ARRAY [' '..'_'] OF symbol;
rop: ARRAY [1..rswmax] OF operator;
sop: ARRAY [' '..'_'] OF operator;
na: ARRAY[namekind] OF ARRAY[1..stdmax] OF alfa; (* PASCAL NAMES OF THE KNOWN RUNTIMES.*)
namax: ARRAY[namekind] OF integer; (* NUMBER OF NAMES IN NA FOR EACH FIRST SUBSCRIPT.*)
extna: ARRAY[declproc..declfunc] OF ARRAY[1..extpfmax] OF alfa; (* SIX-LETTER NAMES OF THOSE RUNTIMES.*)
extlanguage: ARRAY[declproc..declfunc] OF ARRAY[1..extpfmax] OF symbol; (* FOR CALLING CONVENTIONS.*)
%24 EXTADDR: EXTADDRARRAY; (* 19. ACTUAL ADDRESSES OF THE PREDECLARED RUNTIMES.*) \
%13 (* 14.*)
mnemonics : ARRAY[1..45] OF PACKED ARRAY[1..60] OF char ;
showibit : ARRAY[ibrange] OF char;
showrelo : ARRAY[boolean] OF char;
showref : ARRAY[coderefs] OF char;
(* 14.*) \
write_support, read_support: ARRAY[scalarform,scalar..power] OF supports;
(*LABEL PROCESSING:*)
(*******************)
jumper: 0..jump_max;
jump_table: PACKED ARRAY[jump_range] OF addrrange;
jump_address: addrrange;
%24 (* 24. FOR INITPROCEDURES IN PASSGO.*)
INITPROCCOUNT: INTEGER;
INITPRADDRESS: PACKED ARRAY [0..99] OF ADDRRANGE;
(* 24.*) \
(*OTHER VARIABLES:*)
(********************)
relocation_block: PACKED RECORD
CASE integer OF
1: (component: ARRAY[1..20] OF integer);
2: (item: addrrange; count: addrrange;
relocator: relword;
code: ARRAY[0..17] OF integer)
END;
runtime_support: PACKED RECORD
name: ARRAY[supports] OF alfa;
link: PACKED ARRAY[supports] OF addrrange
END;
code_array: codepointer;
code_reference: refpointer;
%13 command_buffer: bufferpointer; (* 18.*) \
code_relocation: relpointer;
change : PACKED RECORD
CASE change_form OF
intcst :(wkonst: integer);
pdp10code:(winstr: pdp10instr);
realcst :(wreal: real);
strcst :(wstring: charword);
sixbitcst:(wsixbit: PACKED ARRAY[1..6] OF 0..77B);
halfwd :(wlefthalf: addrrange ; wrighthalf : addrrange);
pdp10bp :(wbyte: bpointer);
radix :(flag: flagrange; symbol: radixrange)
END;
regc, (*TOP OF REGISTERSTACK*)
regcmax: acrange; (*MAXIMUM OF REGISTERS FOR EXPRESSION STACK*)
cix, (*CODE-ARRAY INDEX*)
stacksize1, stacksize2, (*TO INSERT LCMAX IN PROCEDURE/FUNCTION ENTRY CODE*)
pfstart: integer; (*START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.*)
lcmax: addrrange; lcp: ctp;
headline: integer; (* 27. LINE NUMBER OF THE HEADER OF THIS PROCEDURE*)
procfile, (* 27. FILE WITH PROCEDURE NAMES AND LINE NUMBERS*)
tempcore, source, list : text;
object: FILE OF integer; (*26. A FAKE REL FILE FOR DEBUGGING OF PASSGO*)
withix: integer; (*TOP OF WITH-REG STACK*)
highest_code, (*HIGH SEG. BREAK*)
main_start, (*START OF BODY OF MAIN*)
idtree, (*POINTER TO THE IDENTIFIER-TREE*)
name_address, (*ADDR OF PROGRAM-NAME(ALFA-STRING)*)
start_address: addrrange; (*STARTADDRESS*)
lparmptr, backwparmptr: ptp;
day, timeofday, programname: alfa;
entry: ARRAY[0..entrymax] OF alfa;
%13 object_file, (* 14.*) \
procname_file, (* 27. FILE NAME FOR DUMP OF PROCEDURE NAMES/LINES*)
source_file, list_file: PACKED ARRAY [1..9] OF char;
(* 23. RUNTIME REPORTED BY THE LIBRARY PROCEDURES.*)
core: ARRAY[1..2] OF integer;
nameversion: PACKED ARRAY[1..5] OF char; (*VERSION NAME FOR CONDITIONALLY COMPILED*)
goodversion, (*VERSION NUMBER TO BE CONDITIONALLY COMPILED*) (* 8.*)
maxruncore,
start_channel, code_size, runcore, parregcmax: integer;
%13 entry_done: boolean; (* 19.*) \
(* 25. STRING LENGTH FOR CALL OF STRING-MANAGING PROCEDURES.*)
sstringstart: boolean;
sstringlength: sstrptr;
pctp : ctp;
list_protection , list_ufd : integer ;
list_device : PACKED ARRAY [1..6] OF char ;
suptindex: supports; (* 26.*)
(* 4. ALLOW FOR FLEXIBLE NAME OF PCREF FILE; KEEP TABLE OF PCREF SWITCHES.*)
%13 pcreffile, (* 14.*) \
pcreftmpfile: PACKED ARRAY [1..9] OF char;
%13 pcrefdevice, (* 14.*) \
source_device: PACKED ARRAY[1..6] OF char;
%24 PCREFFILE,
PCREFDEVICE: ALFA; (* 14.*) \
pcrefppn, pcrefcore: integer;
pcrefoption_name: PACKED ARRAY [1..maxpcrefoption] OF alfa;
(* 1. ALLOW FOR FLEXIBLE NAME OF LINKER-LOADER.*)
linker_file,
link_tmpfile: PACKED ARRAY[1..9] OF char;
link_device: PACKED ARRAY[1..6] OF char;
%13 (* 17.*)
link_ppn: integer;
library_index: integer;
library_order: PACKED ARRAY[1..4] OF symbol;
library: ARRAY[pascalsy..fortransy] OF RECORD
chained, called: boolean;
name: alfa;
projnr: addrrange;
prognr: addrrange;
device: alfa
END;
(* 17.*) \
(* 28. STATEMENT COUNTS*)
(***********************)
%13 lastlcmain: addrrange; \ (*starting address of the current block of upto 100 counters*)
%13 line_count: cntarray; \ (*the current upto 100 counters*)
counter: 1..101; (*how many counters are in the current record*)
gotomarkers, (*To prevent markers for GOTO out of block*)
(*from mixing with counters*)
startofcounts,endofcounts: addrrange; (*addresses of the block of counters*)
%24 FIRSTCNTP,LASTCNTP: CNTP; \ (*to save them in PASSGO to generate loading code*)
kntname: alfa; (*name of the file that will be created*)
entercount: boolean; (*flag for delayed insertion of a counter*)
(*------------------------------------------------------------------------------*)
(* INITPROCEDURES. *)
%13 (* 14. THE OBJECT CODE LISTING IS NOT IN PASSGO *)
INITPROCEDURE (* MNEMONICS *) ;
BEGIN
mnemonics[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
mnemonics[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
mnemonics[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
mnemonics[ 4] := '***037CALL INIT ***042***043***044***045***046CALLI OPEN ' ;
mnemonics[ 5] := 'TTCALL***052***053***054RENAMEIN OUT SETSTSSTATO STATUS' ;
mnemonics[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
mnemonics[ 7] := 'USETO LOOKUPENTER UJEN ***101***102***103***104***105***106' ;
mnemonics[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
mnemonics[ 9] := '***121***122***123***124***125***126***127UFA DFN FSC ' ;
mnemonics[10] := 'IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR ' ;
mnemonics[11] := 'FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM ' ;
mnemonics[12] := 'FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV ' ;
mnemonics[13] := 'FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM ' ;
mnemonics[14] := 'MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM ' ;
mnemonics[15] := 'MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM ' ;
mnemonics[16] := 'MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ' ;
mnemonics[17] := 'ROT LSH JFFO ASHC ROTC LSHC ***247EXCH BLT AOBJP ' ;
mnemonics[18] := 'AOBJN JRST JFCL XCT ***257PUSHJ PUSH POP POPJ JSR ' ;
mnemonics[19] := 'JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM ' ;
mnemonics[20] := 'SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM ' ;
mnemonics[21] := 'CAML CAME CAMLE CAMA CAMGE CAMN CAMG JUMP JUMPL JUMPE ' ;
mnemonics[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP SKIPL SKIPE SKIPLESKIPA ' ;
mnemonics[23] := 'SKIPGESKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN ' ;
mnemonics[24] := 'AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ ' ;
mnemonics[25] := 'SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE ' ;
mnemonics[26] := 'SOSLE SOSA SOSGE SOSN SOSG SETZ SETZI SETZM SETZB AND ' ;
mnemonics[27] := 'ANDI ANDM ANDB ANDCA ANDCAIANDCAMANDCABSETM SETMI SETMM ' ;
mnemonics[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA SETAI SETAM SETAB XOR ' ;
mnemonics[29] := 'XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBIANDCBM' ;
mnemonics[30] := 'ANDCBBEQV EQVI EQVM EQVB SETCA SETCAISETCAMSETCABORCA ' ;
mnemonics[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM ORCMI ORCMM ' ;
mnemonics[32] := 'ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB HLL ' ;
mnemonics[33] := 'HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM ' ;
mnemonics[34] := 'HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO ' ;
mnemonics[35] := 'HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM ' ;
mnemonics[36] := 'HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ ' ;
mnemonics[37] := 'HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM ' ;
mnemonics[38] := 'HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE ' ;
mnemonics[39] := 'HLREI HLREM HLRES TRN TLN TRNE TLNE TRNA TLNA TRNN ' ;
mnemonics[40] := 'TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ ' ;
mnemonics[41] := 'TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE ' ;
mnemonics[42] := 'TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLZE TRCA ' ;
mnemonics[43] := 'TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN ' ;
mnemonics[44] := 'TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO ' ;
mnemonics[45] := 'TSO TDOE TSOE TDOA TSOA TDON TSON ***700 ' ;
showibit[0] := ' '; showibit[1] := '@';
showrelo[false] := ' '; showrelo[true] := '''';
showref[noref] := ' '; showref[constref] := 'C';
showref[externref] := 'E'; showref[noinstr] := ' ';
showref[forwardref] := 'F'; showref[gotoref] := 'G';
showref[pointref] := 'P'; showref[saveref] := 'S';
showref[debugref] := 'D';
END (* MNEMONICS *) ;
(* 14.*) \
%13 (* 14. PASCAL VERSION.*)
INITPROCEDURE (*SEARCH LIBRARIES*) ;
BEGIN
(* INSERT (???) DEVICE, PROJNR, PROGNR AND CORE FOR PASLIB AND PCREF *)
library[pascalsy].chained := false;
library[fortransy].chained := false;
library[pascalsy].called := false;
library[fortransy].called := false;
library[pascalsy].name := 'PASLIB ';
library[fortransy].name := 'FORLIB ';
library[pascalsy].device := 'SYS '; (* 0. *)
library[fortransy].device := 'SYS ';
library[pascalsy].projnr := 0;
library[fortransy].projnr := 0;
library[pascalsy].prognr := 0;
library[fortransy].prognr := 0;
(* 4. FLEXIBLE NAME FOR CROSS_REFERENCER*)
pcreffile := 'PCREF ';
pcreftmpfile := 'PCR TMP';
pcrefdevice := 'SYS '; (* 0.*)
pcrefppn := 0;
pcrefcore := 100;
(* 1. FLEXIBLE NAME FOR THE LINKER.*)
linker_file := 'LINK ';
link_tmpfile := 'LNK TMP';
link_device := 'SYS ';
link_ppn := 0;
END (*SEARCH LIBRARIES*) ;
(* 14.*) \
%24 (* PASSGO VERSION.*)
INITPROCEDURE (*SEARCH LIBRARIES*);
BEGIN
PCREFFILE := 'PCREF ';
PCREFTMPFILE := 'PCR TMP';
PCREFDEVICE := 'SYS ';
PCREFPPN := 0;
PCREFCORE := 100;
END (*SEARCH LIBRARIES*);
(* 14.*) \
INITPROCEDURE (*STANDARD NAMES*) ;
BEGIN
na[stdfile, 1] := 'INPUT '; na[stdfile, 2] := 'OUTPUT '; na[stdfile, 3] := 'TTY ';
na[stdfile, 4] := 'TTYOUTPUT ';
na[stdproc, 1] := 'GET '; na[stdproc, 2] := 'GETLN '; na[stdproc, 3] := 'PUT ';
na[stdproc, 4] := 'PUTLN '; na[stdproc, 5] := 'RESET '; na[stdproc, 6] := 'REWRITE ';
na[stdproc, 7] := 'READ '; na[stdproc, 8] := 'READLN '; na[stdproc, 9] := 'BREAK ';
na[stdproc,10] := 'WRITE '; na[stdproc,11] := 'WRITELN '; na[stdproc,12] := 'PACK ';
na[stdproc,13] := 'UNPACK '; na[stdproc,14] := 'NEW '; na[stdproc,15] := '$$$1 ';
na[stdproc,16] := '$$$2 '; na[stdproc,17] := 'GETLINENR '; na[stdproc,18] := '$$$3 ';
na[stdproc,19] := 'PAGE '; na[stdproc,20] := 'PROTECTION'; na[stdproc,21] := 'CALL ';
na[stdproc,22] := 'DATE '; na[stdproc,23] := 'TIME '; na[stdproc,24] := 'DISPOSE ';
na[stdproc,25] := 'HALT '; na[stdproc,26] := 'GETSEG '; na[stdproc,27] := 'PUTSEG ';
na[stdproc,28] := 'MESSAGE '; na[stdproc,29] := 'LINELIMIT ';
na[stdfunc, 1] := 'REALTIME '; na[stdfunc, 2] := 'ABS '; na[stdfunc, 3] := 'SQR ';
na[stdfunc, 4] := '$$$4 '; na[stdfunc, 5] := 'ODD '; na[stdfunc, 6] := 'ORD ';
na[stdfunc, 7] := 'CHR '; na[stdfunc, 8] := 'PRED '; na[stdfunc, 9] := 'SUCC ';
na[stdfunc,10] := 'EOF '; na[stdfunc,11] := 'EOLN '; na[stdfunc,12] := 'CLOCK ';
na[stdfunc,13] := 'CARD '; na[stdfunc,14] := '$$$5 '; na[stdfunc,15] := 'LOWERBOUND';
na[stdfunc,16] := 'UPPERBOUND'; na[stdfunc,17] := 'EOS '; na[stdfunc,18] := '$$$6 ';
na[stdfunc,19] := 'MIN '; na[stdfunc,20] := 'MAX '; na[stdfunc,21] := 'FIRST ';
na[stdfunc,22] := 'LAST ';
na[declfunc, 1] := 'COS '; na[declfunc, 2] := 'EXP '; na[declfunc, 3] := 'SQRT ';
na[declfunc, 4] := 'LN '; na[declfunc, 5] := 'ARCTAN '; na[declfunc, 6] := 'LOG ';
na[declfunc, 7] := 'SIND '; na[declfunc, 8] := 'COSD '; na[declfunc, 9] := 'SINH ';
na[declfunc,10] := 'COSH '; na[declfunc,11] := 'TANH '; na[declfunc,12] := 'ARCSIN ';
na[declfunc,13] := 'ARCCOS '; na[declfunc,14] := 'RANDOM '; na[declfunc,15] := 'SIN ';
na[declfunc,16] := 'ROUND '; na[declfunc,17] := 'EXPO '; na[declfunc,18] := 'OPTION ';
na[declfunc,19] := '$$$7 '; na[declfunc,20] := 'TRUNC '; na[declfunc,21] := 'LENGTH '; (* 25.*)
na[declfunc,22] := 'GETCHAR '; na[declfunc,23] := 'POS '; na[declfunc,24] := 'STRLT '; (* 25.*)
na[declfunc,25] := 'STRLE '; na[declfunc,26] := 'STREQ '; na[declfunc,27] := 'STRGE '; (* 25.*)
na[declfunc,28] := 'STRGT '; na[declfunc,29] := 'STRNE '; (* 25.*)
na[stdconst, 1] := 'FALSE '; na[stdconst, 2] := 'TRUE '; na[stdconst, 3] := 'NUL ';
na[stdconst, 4] := 'SOH '; na[stdconst, 5] := 'STX '; na[stdconst, 6] := 'ETX ';
na[stdconst, 7] := 'EOT '; na[stdconst, 8] := 'ENQ '; na[stdconst, 9] := 'ACK ';
na[stdconst,10] := 'BEL '; na[stdconst,11] := 'BS '; na[stdconst,12] := 'HT ';
na[stdconst,13] := 'LF '; na[stdconst,14] := 'VT '; na[stdconst,15] := 'FF ';
na[stdconst,16] := 'CR '; na[stdconst,17] := 'SO '; na[stdconst,18] := 'SI ';
na[stdconst,19] := 'DLE '; na[stdconst,20] := 'DC1 '; na[stdconst,21] := 'DC2 ';
na[stdconst,22] := 'DC3 '; na[stdconst,23] := 'DC4 '; na[stdconst,24] := 'NAK ';
na[stdconst,25] := 'SYN '; na[stdconst,26] := 'ETB '; na[stdconst,27] := 'CAN ';
na[stdconst,28] := 'EM '; na[stdconst,29] := 'SUB '; na[stdconst,30] := 'ESC ';
na[stdconst,31] := 'FS '; na[stdconst,32] := 'GS '; na[stdconst,33] := 'RS ';
na[stdconst,34] := 'US '; na[stdconst,35] := 'SP '; na[stdconst,36] := 'DEL ';
na[declproc, 1] := 'GETFILENAM'; na[declproc, 2] := 'GETOPTION '; na[declproc, 3] := 'GETSTATUS ';
(* 7. NEW RUNTIMES FROM THE CCL SCANNER.*)
na[declproc, 4] := 'ASKFILENAM'; na[declproc, 5] := 'STARTFILE '; na[declproc, 6] := 'GETPARAMET';
na[declproc, 7] := 'GETNEXTCAL'; na[declproc, 8] := 'FILNAM '; na[declproc, 9] := 'REENTER ';
na[declproc,10] := 'SETTIME '; na[declproc,11] := 'TIMEREPORT'; na[declproc,12] := 'RUNTIME ';
na[declproc,13] := 'ELAPSEDTIM'; na[declproc,14] := 'PUTCHAR '; na[declproc,15] := 'ASSIGN '; (* 25.*)
na[declproc,16] := 'SUBSTR '; na[declproc,17] := 'CONCAT '; na[declproc,18] := 'SETRAN '; (*25.*) (*29.*)
namax[stdfile] := 4; namax[stdproc] := 29; namax[stdfunc] := 22; (* 25.*)
namax[declfunc] := 29; namax[declproc] := 18; namax[stdconst] := 36; (* 25.*)
END (*STANDARD NAMES*) ;
INITPROCEDURE (*EXTERNAL PROCEDURE/FUNCTION NAMES*);
BEGIN
extna[declfunc, 1] := 'COS '; extlanguage[declfunc, 1] := fortransy;
extna[declfunc, 2] := 'EXP '; extlanguage[declfunc, 2] := fortransy;
extna[declfunc, 3] := 'PSQRT '; extlanguage[declfunc, 3] := pascalsy; (* 29.*)
extna[declfunc, 4] := 'ALOG '; extlanguage[declfunc, 4] := fortransy;
extna[declfunc, 5] := 'ATAN '; extlanguage[declfunc, 5] := fortransy;
extna[declfunc, 6] := 'ALOG10 '; extlanguage[declfunc, 6] := fortransy;
extna[declfunc, 7] := 'SIND '; extlanguage[declfunc, 7] := fortransy;
extna[declfunc, 8] := 'COSD '; extlanguage[declfunc, 8] := fortransy;
extna[declfunc, 9] := 'SINH '; extlanguage[declfunc, 9] := fortransy;
extna[declfunc,10] := 'COSH '; extlanguage[declfunc,10] := fortransy;
extna[declfunc,11] := 'TANH '; extlanguage[declfunc,11] := fortransy;
extna[declfunc,12] := 'ASIN '; extlanguage[declfunc,12] := fortransy;
extna[declfunc,13] := 'ACOS '; extlanguage[declfunc,13] := fortransy;
extna[declfunc,14] := 'RAN '; extlanguage[declfunc,14] := fortransy;
extna[declfunc,15] := 'SIN '; extlanguage[declfunc,15] := fortransy;
extna[declfunc,16] := 'ROUND '; extlanguage[declfunc,16] := pascalsy;
extna[declfunc,17] := 'EXPO '; extlanguage[declfunc,17] := pascalsy;
extna[declfunc,18] := 'OPTION '; extlanguage[declfunc,18] := pascalsy;
extna[declfunc,19] := 'UNDEFI '; extlanguage[declfunc,19] := pascalsy;
extna[declfunc,20] := 'TRUNC '; extlanguage[declfunc,20] := pascalsy;
extna[declfunc,21] := 'LENGTH '; extlanguage[declfunc,21] := pascalsy; (* 25.*)
extna[declfunc,22] := 'GETCHR '; extlanguage[declfunc,22] := pascalsy; (* 25.*)
extna[declfunc,23] := 'POS '; extlanguage[declfunc,23] := pascalsy; (* 25.*)
extna[declfunc,24] := 'STRLT '; extlanguage[declfunc,24] := pascalsy; (* 25.*)
extna[declfunc,25] := 'STRLE '; extlanguage[declfunc,25] := pascalsy; (* 25.*)
extna[declfunc,26] := 'STREQ '; extlanguage[declfunc,26] := pascalsy; (* 25.*)
extna[declfunc,27] := 'STRGE '; extlanguage[declfunc,27] := pascalsy; (* 25.*)
extna[declfunc,28] := 'STRGT '; extlanguage[declfunc,28] := pascalsy; (* 28.*)
extna[declfunc,29] := 'STRNE '; extlanguage[declfunc,29] := pascalsy; (* 25.*)
extna[declproc, 1] := 'GETFIL '; extlanguage[declproc, 1] := pascalsy;
extna[declproc, 2] := 'GETOPT '; extlanguage[declproc, 2] := pascalsy;
extna[declproc, 3] := 'GETSTA '; extlanguage[declproc, 3] := pascalsy;
(* 7. NEW RUNTIMES FROM THE CCL SCANNER.*)
extna[declproc, 4] := 'ASKFIL '; extlanguage[declproc, 4] := pascalsy;
extna[declproc, 5] := 'STARTF '; extlanguage[declproc, 5] := pascalsy;
extna[declproc, 6] := 'GETPAR '; extlanguage[declproc, 6] := pascalsy;
extna[declproc, 7] := 'GETNEX '; extlanguage[declproc, 7] := pascalsy;
extna[declproc, 8] := 'FILNAM '; extlanguage[declproc, 8] := pascalsy;
extna[declproc, 9] := 'REENTE '; extlanguage[declproc, 9] := pascalsy;
extna[declproc,10] := 'SETTIM '; extlanguage[declproc,10] := pascalsy;
extna[declproc,11] := 'TIMERE '; extlanguage[declproc,11] := pascalsy;
extna[declproc,12] := 'RUNTIM '; extlanguage[declproc,12] := pascalsy;
extna[declproc,13] := 'ELAPSE '; extlanguage[declproc,13] := pascalsy;
extna[declproc,14] := 'PUTCHA '; extlanguage[declproc,14] := pascalsy; (* 25.*)
extna[declproc,15] := 'ASSIGN '; extlanguage[declproc,15] := pascalsy; (* 25.*)
extna[declproc,16] := 'SUBSTR '; extlanguage[declproc,16] := pascalsy; (* 25.*)
extna[declproc,17] := 'CONCAT '; extlanguage[declproc,17] := pascalsy; (* 25.*)
extna[declproc,18] := 'SETRAN '; extlanguage[declproc,18] := fortransy;
END (*EXTERNAL PROCEDURE/FUNCTION NAMES*);
INITPROCEDURE (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
BEGIN
(* 13. REORDERED ACCORDING TO THE DECLARATION OF TYPE SUPPORTS.*)
runtime_support.name[stackoverflow] := 'CORERR ';
runtime_support.name[errorinassignment] := 'SRERR ';
runtime_support.name[indexerror] := 'INXERR ';
runtime_support.name[overflow] := 'OVERF. ';
runtime_support.name[inputerror] := 'IPTERR ';
runtime_support.name[errorinset] := 'SETERR ';
runtime_support.name[nocoreavailable] := 'NOCORE ';
runtime_support.name[allocate] := 'NEW ';
runtime_support.name[free] := 'FREE ';
runtime_support.name[exitprogram] := 'END ';
runtime_support.name[runprogram] := 'RUNPGM ';
runtime_support.name[readpgmparameter] := 'GETPAR ';
runtime_support.name[resetfile] := 'RESETF ';
runtime_support.name[rewritefile] := 'REWRIT ';
runtime_support.name[opentty] := 'TTYOPN ';
runtime_support.name[fortranreset] := 'RESET. ';
runtime_support.name[fortranexit] := 'EXIT. ';
runtime_support.name[closefile] := 'CLSFIL ';
runtime_support.name[getcharacter] := 'GETCH ';
runtime_support.name[getfile] := 'GET ';
runtime_support.name[getline] := 'GETLN ';
runtime_support.name[putfile] := 'PUT ';
runtime_support.name[putline] := 'PUTLN ';
runtime_support.name[putpage] := 'PUTPG ';
runtime_support.name[putbuffer] := 'PUTBUF ';
runtime_support.name[initializedebug] := 'INDEB. ';
runtime_support.name[enterdebug] := 'EXDEB. ';
runtime_support.name[loaddebug] := 'DEBUG ';
runtime_support.name[convertintegertoreal] := 'INTREA ';
runtime_support.name[asciitime] := 'TIME. ';
runtime_support.name[asciidate] := 'DATE. ';
runtime_support.name[readreal] := 'READR ';
runtime_support.name[readinteger] := 'READI ';
runtime_support.name[readcharacter] := 'READC ';
runtime_support.name[readstring] := 'READS ';
runtime_support.name[readpackedstring] := 'READPS ';
runtime_support.name[writecharacter] := 'WRITEC ';
runtime_support.name[writedefcharacter] := 'WRITC1 ';
runtime_support.name[writestring] := 'WRTUST ';
runtime_support.name[writedefstring] := 'WRTUS1 ';
runtime_support.name[writepackedstring] := 'WRTPST ';
runtime_support.name[writedefpackedstring] := 'WRTPS1 ';
runtime_support.name[writeboolean] := 'WRTBOL ';
runtime_support.name[writedefboolean] := 'WRTBO1 ';
runtime_support.name[writereal] := 'WRTREA ';
runtime_support.name[writedef1real] := 'WRTRE1 ';
runtime_support.name[writedef2real] := 'WRTRE2 ';
runtime_support.name[writeinteger] := 'WRTINT ';
runtime_support.name[writedefinteger] := 'WRTIN1 ';
runtime_support.name[writehexadecimal] := 'WRTHEX ';
runtime_support.name[writedefhexadecimal] := 'WRTHX1 ';
runtime_support.name[writeoctal] := 'WRTOCT ';
runtime_support.name[writedefoctal] := 'WRTOC1 ';
runtime_support.name[readirange] := 'READIR ';
runtime_support.name[readcrange] := 'READCR ';
runtime_support.name[readrrange] := 'READRR ';
runtime_support.name[readscalar] := 'READSC ';
runtime_support.name[readiset] := 'READIS ';
runtime_support.name[readcset] := 'READCS ';
runtime_support.name[readdset] := 'READDS ';
runtime_support.name[wrtscalar] := 'WRTSCA ';
runtime_support.name[wrtiset] := 'WRTISE ';
runtime_support.name[wrtcset] := 'WRTCSE ';
runtime_support.name[wrtdset] := 'WRTDSE ';
runtime_support.name[startclock] := 'SETTIM ';
runtime_support.name[showruntime] := 'TIMERE ';
runtime_support.name[badpointer] := 'PTRERR ';
runtime_support.name[readpseudostring] := 'READST '; (* 25.*)
runtime_support.name[writepseudostring] := 'WRTSTR '; (* 25.*)
runtime_support.name[writedefpseudostring] := 'WRTST1 '; (* 25.*)
runtime_support.name[dumpcounts ] := 'DPCNTS ';
read_support[integerform,subrange] := readirange;
read_support[integerform,power] := readiset;
read_support[integerform,scalar] := readinteger;
read_support[realform,subrange] := readrrange;
read_support[realform,scalar] := readreal;
read_support[charform,subrange] := readcrange;
read_support[charform,power] := readcset;
read_support[charform,scalar] := readcharacter;
read_support[declaredform,subrange] := readscalar;
read_support[declaredform,power] := readdset;
read_support[declaredform,scalar] := readscalar;
write_support[integerform,power] := wrtiset;
write_support[charform,power] := wrtcset;
write_support[declaredform,power] := wrtdset;
write_support[declaredform,subrange] := wrtscalar;
write_support[declaredform,scalar] := wrtscalar;
END (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
INITPROCEDURE (*INITSCALARS*) ;
BEGIN
programname := ' ';
nameversion := ' ';
forward_pointer_type := NIL; lastbtp := NIL; fglobptr := NIL ; fileptr := NIL ;
localpfptr := NIL; externpfptr := NIL; globtestp := NIL; last_label := NIL;
errmptr := NIL; parmptr := NIL; declscalptr := NIL; backwparmptr := NIL;
sdeclscalptr := NIL; sexternpfptr := NIL; sfileptr := NIL;
slastbtp := NIL; globnewlink := NIL;
%13 list_code := false; \ loadnoptr := true; initglobals := false ; runtime_check := true;
followerror := false; errorinline := false; reset_possible := true; first_symbol := true;
dp := true; search_error := true; errorflag := false ; %13 external := false; \
no_code_gen := false; hassoslines := true; logfile := false;
%13 entry_done := false; \ debug := false; debug_switch := false; lptfile := false;
errorexit := false; ttyread := false; %13 load_and_go := false; loadit := false; \
cross_reference := false; %13 fortran_enviroment := false; \ overrun := false;
incondcomp := false; (* 8. INITIALLY OUT OF CONDITIONAL COMPILATION.*)
outputwrite := false; inputpar := false; outputpar := false; (* 13.*)
entercount := false; counting := false; (* 28.*)
%13 ic := high_start; (*START OF HIGHSEGMENT*) (* 14.*) \
%13 lc := low_start; (*START OF LOWSEGMENT AVAILABLE TO PROGRAM*) (* 14.*) \
chcnt := 0; linecnt := 1; pagecnt := 1; lastline := -1;
tchcnt := 0; line500 := 1;
aos := b0; %13 library_index := 0; (* 17.*) \ errinx := 0;
debugentry.standardidtree := 0; debugentry.globalidtree := 0; start_channel := 0;
parregcmax := stdparregcmax; chcntmax := stdchcntmax;
code_size := cixmax; %12 RUNCORE := 170B; \ jumper := 0; jump_address := 0;
%34 runcore := 0; \ maxruncore := 170B;
errorcount := 0; entries := 0; %13 program_count := 0; (* 14.*) \
lastpage := 0; goodversion := -1; (* 8. VERSION TO BE TAKEN.*)
%24 EXECODECOUNT := MAXFILECODE; (* 18.*) \
%24 INITPROCCOUNT := -1; (* 24.*) \
END (*INITSCALARS*) ;
INITPROCEDURE (*INITSETS*) ;
BEGIN
digits := ['0'..'9'];
letters := ['A'..'Z'];
hexadigits := ['0'..'9','A'..'F'];
lettersordigits := [ '0'..'9','A'..'Z'];
identchars := ['0'..'9','A'..'Z','_'];
languagesys := [fortransy,pascalsy];
constbegsys := [addop,intconst,realconst,stringconst,ident];
simptypebegsys := [addop,intconst,realconst,stringconst,ident,lparent] ;
typebegsys := [addop,intconst,realconst,stringconst,ident,lparent,arrow,
packedsy,arraysy,recordsy,setsy,filesy,segmentsy] ; (* 13.*)
typedels := [arraysy,recordsy,setsy,filesy];
blockbegsys := [labelsy,constsy,typesy,varsy,initprocsy,proceduresy,functionsy,beginsy];
selectsys := [arrow,period,lbrack];
facbegsys := [intconst,realconst,stringconst,ident,lparent,lbrack,notsy];
statbegsys := [beginsy,gotosy,ifsy,whilesy,repeatsy,loopsy,forsy,withsy,casesy]
END (*INITSETS*) ;
INITPROCEDURE (*RESERVED WORDS*) ;
BEGIN
rw[ 1] := 'IF '; rw[ 2] := 'DO '; rw[ 3] := 'OF ';
rw[ 4] := 'TO '; rw[ 5] := 'IN '; rw[ 6] := 'OR ';
rw[ 7] := 'END '; rw[ 8] := 'FOR '; rw[ 9] := 'VAR ';
rw[10] := 'DIV '; rw[11] := 'MOD '; rw[12] := 'SET ';
rw[13] := 'AND '; rw[14] := 'NOT '; rw[15] := 'THEN ';
rw[16] := 'ELSE '; rw[17] := 'WITH '; rw[18] := 'GOTO ';
rw[19] := 'LOOP '; rw[20] := 'CASE '; rw[21] := 'TYPE ';
rw[22] := 'FILE '; rw[23] := 'EXIT '; rw[24] := 'BEGIN ';
rw[25] := 'UNTIL '; rw[26] := 'WHILE '; rw[27] := 'ARRAY ';
rw[28] := 'CONST '; rw[29] := 'LABEL '; rw[30] := 'EXTERN ';
rw[31] := 'RECORD '; rw[32] := 'DOWNTO '; rw[33] := 'PACKED ';
rw[34] := 'OTHERS '; rw[35] := 'REPEAT '; rw[36] := 'FORTRAN ';
rw[37] := 'FORWARD '; rw[38] := 'PROGRAM '; rw[39] := 'FUNCTION ';
rw[40] := 'PROCEDURE '; rw[41] := 'SEGMENTED '; rw[42] := 'INITPROCED';
frw[1] := 1; frw[2] := 1; frw[3] := 7; frw[4] := 15; frw[5] := 24;
frw[6] := 30; frw[7] := 36; frw[8] := 39; frw[9] := 40; frw[10] := 42;
frw[11] := 43
END (*RESERVED WORDS*) ;
INITPROCEDURE (*SYMBOLS*) ;
BEGIN
rsy[1]:=ifsy; rsy[2]:=dosy; rsy[3]:=ofsy;
rsy[4]:=tosy; rsy[8]:=forsy; rsy[12]:=setsy;
rsy[5]:=relop; rsy[6]:=addop; rsy[7]:=endsy;
rsy[9]:=varsy; rsy[10]:=mulop; rsy[11]:=mulop;
rsy[13]:=mulop; rsy[14]:=notsy; rsy[15]:=thensy;
rsy[16]:=elsesy; rsy[17]:=withsy; rsy[18]:=gotosy;
rsy[19]:=loopsy; rsy[20]:=casesy; rsy[21]:=typesy;
rsy[22]:=filesy; rsy[23]:=exitsy; rsy[24]:=beginsy;
rsy[25]:=untilsy; rsy[26]:=whilesy; rsy[27]:=arraysy;
rsy[28]:=constsy; rsy[29]:=labelsy; rsy[30]:=externsy;
rsy[31]:=recordsy; rsy[32]:=downtosy; rsy[33]:=packedsy;
rsy[34]:=otherssy; rsy[35]:=repeatsy; rsy[36]:=fortransy;
rsy[37]:=forwardsy; rsy[38]:=programsy; rsy[39]:=functionsy;
rsy[40]:=proceduresy; rsy[41]:=segmentsy; rsy[42]:=initprocsy;
ssy['A'] := othersy; ssy['B'] := othersy; ssy['C'] := othersy;
ssy['D'] := othersy; ssy['E'] := othersy; ssy['F'] := othersy;
ssy['G'] := othersy; ssy['H'] := othersy; ssy['I'] := othersy;
ssy['J'] := othersy; ssy['K'] := othersy; ssy['L'] := othersy;
ssy['M'] := othersy; ssy['N'] := othersy; ssy['O'] := othersy;
ssy['P'] := othersy; ssy['Q'] := othersy; ssy['R'] := othersy;
ssy['S'] := othersy; ssy['T'] := othersy; ssy['U'] := othersy;
ssy['V'] := othersy; ssy['W'] := othersy; ssy['X'] := othersy;
ssy['Y'] := othersy; ssy['Z'] := othersy; ssy['0'] := othersy;
ssy['1'] := othersy; ssy['2'] := othersy; ssy['3'] := othersy;
ssy['4'] := othersy; ssy['5'] := othersy; ssy['6'] := othersy;
ssy['7'] := othersy; ssy['8'] := othersy; ssy['9'] := othersy;
ssy['+'] := addop; ssy['-'] := addop; ssy['*'] := mulop;
ssy['/'] := mulop; ssy['('] := lparent; ssy[')'] := rparent;
ssy['$'] := othersy; ssy['='] := relop; ssy[' '] := othersy;
ssy[','] := comma; ssy['.'] := period; ssy[''''] := othersy;
ssy['['] := lbrack; ssy[']'] := rbrack; ssy[':'] := colon;
ssy['#'] := othersy; ssy['%'] := othersy; ssy['!'] := othersy;
ssy['&'] := othersy; ssy['↑'] := arrow; ssy['\'] := othersy;
ssy['<'] := relop; ssy['>'] := relop; ssy['@'] := othersy;
ssy['"'] := othersy; ssy['?'] := othersy; ssy[';'] := semicolon;
ssy['_'] := othersy;
END (*SYMBOLS*) ;
INITPROCEDURE (*OPERATORS*) ;
BEGIN
rop[ 1] := noop; rop[ 2] := noop; rop[ 3] := noop; rop[ 4] := noop;
rop[ 5] := inop; rop[ 6] := orop; rop[ 7] := noop; rop[ 8] := noop;
rop[ 9] := noop; rop[10] := idiv; rop[11] := imod; rop[12] := noop;
rop[13] :=andop; rop[14] := noop; rop[15] := noop; rop[16] := noop;
rop[17] := noop; rop[18] := noop; rop[19] := noop; rop[20] := noop;
rop[21] := noop; rop[22] := noop; rop[23] := noop; rop[24] := noop;
rop[25] := noop; rop[26] := noop; rop[27] := noop; rop[28] := noop;
rop[29] := noop; rop[30] := noop; rop[31] := noop; rop[32] := noop;
rop[33] := noop; rop[34] := noop; rop[35] := noop; rop[36] := noop;
rop[37] := noop; rop[38] := noop; rop[39] := noop; rop[40] := noop;
rop[41] := noop; rop[42] := noop;
sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
sop['='] := eqop; sop['#'] := noop; sop['!'] := noop; sop['&'] := noop;
sop['<'] := ltop; sop['>'] := gtop; sop['@'] := noop; sop['"'] := noop;
sop[' '] := noop; sop['$'] := noop; sop['%'] := noop; sop['('] := noop;
sop[')'] := noop; sop[','] := noop; sop['.'] := noop; sop['0'] := noop;
sop['1'] := noop; sop['2'] := noop; sop['3'] := noop; sop['4'] := noop;
sop['5'] := noop; sop['6'] := noop; sop['7'] := noop; sop['8'] := noop;
sop['9'] := noop; sop[':'] := noop; sop[';'] := noop; sop['?'] := noop;
sop['A'] := noop; sop['B'] := noop; sop['C'] := noop; sop['D'] := noop;
sop['E'] := noop; sop['F'] := noop; sop['G'] := noop; sop['H'] := noop;
sop['I'] := noop; sop['J'] := noop; sop['K'] := noop; sop['L'] := noop;
sop['M'] := noop; sop['N'] := noop; sop['O'] := noop; sop['P'] := noop;
sop['Q'] := noop; sop['R'] := noop; sop['S'] := noop; sop['T'] := noop;
sop['U'] := noop; sop['V'] := noop; sop['W'] := noop; sop['X'] := noop;
sop['Y'] := noop; sop['Z'] := noop; sop['['] := noop; sop['\'] := noop;
sop[']'] := noop; sop['↑'] := noop; sop['_'] := noop; sop[''''] := noop
END (*OPERATORS*) ;
INITPROCEDURE (*RECORD SIZES*);
BEGIN
debentry_size := 8;
idrecsize[types] := 5;
idrecsize[konst] := 6;
idrecsize[vars] := 6;
idrecsize[field] := 6;
idrecsize[proc] := 5;
idrecsize[func] := 5;
idrecsize[labels] := 5;
strecsize[scalar] := 2;
strecsize[subrange] := 4;
strecsize[pointer] := 2;
strecsize[power] := 2;
strecsize[arrays] := 3;
strecsize[records] := 3;
strecsize[files] := 2;
strecsize[tagfwithid] := 3;
strecsize[tagfwithoutid] := 2;
strecsize[variant] := 4
END (*RECORD SIZES*);
INITPROCEDURE (*ERROR MESSAGES*) ;
BEGIN
errmess15[ 1] := '":" EXPECTED ';
errmess15[ 2] := '")" EXPECTED ';
errmess15[ 3] := '"(" EXPECTED ';
errmess15[ 4] := '"[" EXPECTED ';
errmess15[ 5] := '"]" EXPECTED ';
errmess15[ 6] := '";" EXPECTED ';
errmess15[ 7] := '"=" EXPECTED ';
errmess15[ 8] := '"," EXPECTED ';
errmess15[ 9] := '":=" EXPECTED ';
errmess15[10] := '"OF" EXPECTED ';
errmess15[11] := '"DO" EXPECTED ';
errmess15[12] := '"IF" EXPECTED ';
errmess15[13] := '"END" EXPECTED ';
errmess15[14] := '"THEN" EXPECTED';
errmess15[15] := '"EXIT" EXPECTED';
errmess15[16] := 'ILLEGAL SYMBOL ';
errmess15[17] := 'NO SIGN ALLOWED';
errmess15[18] := 'NUMBER EXPECTED';
errmess15[19] := 'NOT IMPLEMENTED';
errmess15[20] := 'ERROR IN TYPE ';
errmess15[21] := 'COMPILER ERROR ';
errmess15[22] := 'DEVICE EXPECTED';
errmess15[23] := 'ERROR IN FACTOR';
errmess15[24] := 'TOO MANY DIGITS';
errmess20[ 1] := '"BEGIN" EXPECTED ';
errmess20[ 2] := '"UNTIL" EXPECTED ';
errmess20[ 3] := 'ERROR IN OPTIONS ';
errmess20[ 4] := 'CONSTANT TOO LARGE ';
errmess20[ 5] := 'DIGIT MUST FOLLOW ';
errmess20[ 6] := 'EXPONENT TOO LARGE ';
errmess20[ 7] := 'CONSTANT EXPECTED ';
errmess20[ 8] := 'SIMPLE TYPE EXPECTED';
errmess20[ 9] := 'IDENTIFIER EXPECTED ';
errmess20[10] := 'REALTYPE NOT ALLOWED';
errmess20[11] := 'MULTIDEFINED LABEL ';
errmess20[12] := 'FILENAME EXPECTED ';
errmess20[13] := 'SET TYPE EXPECTED ';
errmess20[14] := 'UNDEFINED LABEL ';
errmess20[15] := 'UNDECLARED LABEL ';
errmess25[ 1] := '"TO"/"DOWNTO" EXPECTED ';
errmess25[ 2] := '8 OR 9 IN OCTAL NUMBER ';
errmess25[ 3] := 'IDENTIFIER NOT DECLARED ';
errmess25[ 4] := 'FILE NOT ALLOWED HERE ';
errmess25[ 5] := 'INTEGER CONSTANT EXPECTED';
errmess25[ 6] := 'ERROR IN PARAMETERLIST ';
errmess25[ 7] := 'ALREADY FORWARD DECLARED ';
errmess25[ 8] := 'THIS FORMAT FOR REAL ONLY';
errmess25[ 9] := 'VARIANTTYPE MUST BE ARRAY';
errmess25[10] := 'TYPE CONFLICT OF OPERANDS';
errmess25[11] := 'MULTIDEFINED CASE LABEL ';
errmess25[12] := 'FOR INTEGER ONLY "O"/"H" ';
errmess25[13] := 'ARRAY INDEX OUT OF BOUNDS';
errmess25[14] := 'MISSING FILE DECLARATION ';
errmess25[15] := 'LABEL CONSTANT TOO GREAT ';
errmess25[16] := 'LABEL ALREADY DECLARED ';
errmess25[17] := 'END OF PROGRAM NOT FOUND ';
errmess25[18] := 'MORE THAN 72 SET ELEMENTS';
errmess30[ 1] := 'STRING CONSTANT IS TOO LONG ';
errmess30[ 2] := 'IDENTIFIER ALREADY DECLARED ';
errmess30[ 3] := 'SUBRANGE BOUNDS MUST BE SCALAR';
errmess30[ 4] := 'INCOMPATIBLE SUBRANGE TYPES ';
errmess30[ 5] := 'INCOMPATIBLE WITH TAGFIELDTYPE';
errmess30[ 6] := 'INDEX TYPE MAY NOT BE INTEGER ';
errmess30[ 7] := 'TYPE OF VARIABLE IS NOT ARRAY ';
errmess30[ 8] := 'TYPE OF VARIABLE IS NOT RECORD';
errmess30[ 9] := 'NO SUCH FIELD IN THIS RECORD ';
errmess30[10] := 'EXPRESSION TOO COMPLICATED ';
errmess30[11] := 'ILLEGAL TYPE OF OPERAND(S) ';
errmess30[12] := 'TESTS ON EQUALITY ALLOWED ONLY';
errmess30[13] := 'STRICT INCLUSION NOT ALLOWED ';
errmess30[14] := 'FILE COMPARISON NOT ALLOWED ';
errmess30[15] := 'ILLEGAL TYPE OF EXPRESSION ';
errmess30[16] := 'VALUE OF CASE LABEL TOO LARGE ';
errmess30[17] := 'TOO MANY NESTED WITHSTATEMENTS';
errmess30[18] := 'INVALID OR NO PROGRAM HEADING ';
errmess30[19] := 'TOO MANY LABEL DECLARATIONS ';
errmess30[20] := 'INCOMPATIBLE FORMALPARAMETER ';
errmess30[21] := 'STRING PACKAGE IS DISABLED '; (* 25.*)
errmess35[ 1] := 'STRING CONSTANT CONTAINS "<CR><LF>"';
errmess35[ 2] := 'LABEL NOT DECLARED ON THIS LEVEL ';
errmess35[ 3] := 'CALL NOT ALLOWED IN EXTERN PROGRAMS';
errmess35[ 4] := 'MORE THAN 12 FILES DECLARED BY USER';
errmess35[ 5] := 'FILE AS VALUE PARAMETER NOT ALLOWED';
errmess35[ 6] := 'TOO MUCH CODE: USE OPTION CODESIZE ';
errmess35[ 7] := 'NO PACKED STRUCTURE ALLOWED HERE ';
errmess35[ 8] := 'VARIANT MUST BELONG TO TAGFIELDTYPE';
errmess35[ 9] := 'TYPE OF OPERAND(S) MUST BE BOOLEAN ';
errmess35[10] := 'SET ELEMENT TYPES NOT COMPATIBLE ';
errmess35[11] := 'ASSIGNMENT TO FILES NOT ALLOWED ';
errmess35[12] := 'TOO MANY LABELS IN THIS PROCEDURE ';
errmess35[13] := 'INITPROCEDURE NOT ALLOWED HERE ';
errmess35[14] := 'CONTROL VARIABLE MAY NOT BE FORMAL ';
errmess35[15] := 'ILLEGAL TYPE OF FOR-CONTROLVARIABLE';
errmess35[16] := 'ONLY PACKED FILE OF CHAR ALLOWED ';
errmess35[17] := 'CONSTANT NOT IN BOUNDS OF SUBRANGE ';
errmess40[ 1] := 'IDENTIFIER IS NOT OF APPROPRIATE CLASS ';
errmess40[ 2] := 'TAGFIELD TYPE MUST BE SCALAR OR SUBRANGE';
errmess40[ 3] := 'INDEX TYPE MUST BE SCALAR OR SUBRANGE ';
errmess40[ 4] := 'TOO MANY NESTED SCOPES OF IDENTIFIERS ';
errmess40[ 5] := 'POINTER FORWARD REFERENCE UNSATISFIED ';
errmess40[ 6] := ' ';
errmess40[ 7] := 'TYPE OF VARIABLE MUST BE FILE OR POINTER';
errmess40[ 8] := 'MISSING CORRESPONDING VARIANTDECLARATION';
errmess40[ 9] := 'MORE THAN 6 VARIANTS IN CALL OF "NEW" ';
errmess40[10] := 'MORE THAN FOUR ERRORS IN THIS SOURCELINE';
errmess40[11] := 'NO INITIALISATION ON RECORDS OR FILES ';
errmess40[12] := 'PROGRAM TOO BIG FOR PASSGO. USE PASCAL ';
errmess40[13] := 'MORE THAN 100 INITPROCEDURES. USE PASCAL';
errmess45[ 1] := 'LOW BOUND MAY NOT BE GREATER THAN HIGH BOUND ';
errmess45[ 2] := 'IDENTIFIER OR "CASE" EXPECTED IN FIELDLIST ';
errmess45[ 3] := 'TOO MANY NESTED PROCEDURES AND/OR FUNCTIONS ';
errmess45[ 4] := 'FILE DECLARATION IN PROCEDURES NOT ALLOWED ';
errmess45[ 5] := 'MISSING RESULT TYPE IN FUNCTION DECLARATION ';
errmess45[ 6] := 'ASSIGNMENT TO FORMAL FUNCTION IS NOT ALLOWED ';
errmess45[ 7] := 'INDEX TYPE IS NOT COMPATIBLE WITH DECLARATION';
errmess45[ 8] := 'ERROR IN TYPE OF STANDARD PROCEDURE PARAMETER';
errmess45[ 9] := 'ERROR IN TYPE OF STANDARD FUNCTION PARAMETER ';
errmess45[10] := 'REAL AND STRING TAGFIELDS NOT IMPLEMENTED ';
errmess45[11] := 'SET ELEMENT TYPE MUST BE SCALAR OR SUBRANGE ';
errmess45[12] := 'ONLY ASSIGNMENTS ALLOWED IN INITPROCEDURES ';
errmess45[13] := 'NO CONSTANT OR EXPRESSION FOR VAR ARGUMENT ';
errmess45[14] := 'EXTERN DECLARATION NOT ALLOWED IN PROCEDURES ';
errmess45[15] := 'BODY OF FORWARD DECLARED PROCEDURE MISSING ';
errmess45[16] := 'DOUBLE FILE SPECIFICATION IN PROGRAM HEADING ';
errmess45[17] := 'TOO MUCH CODE FOR DEBUG: TRY MORE "CODESIZE" ';
errmess45[18] := 'NO FORMAL-PROC/FUNC IN FORTRAN-SUBROUTINE ';
errmess45[19] := 'THIS VAR ARGUMENT HAS TO BE OF TYPE STRING ';
errmess45[20] := 'GLOBAL VARIABLES REQUIRE TOO MUCH MEMORYSPACE';
errmess50[ 1] := 'TOO MANY FORWARD REFERENCES OF PROCEDURE ENTRIES ';
errmess50[ 2] := 'ASSIGNMENT TO STANDARD FUNCTION IS NOT ALLOWED ';
errmess50[ 3] := 'PARAMETER TYPE DOES NOT AGREE WITH DECLARATION ';
errmess50[ 4] := 'INITIALISATION ONLY BY ASSIGNMENT OF CONSTANTS ';
errmess50[ 5] := 'LABEL TYPE INCOMPATIBLE WITH SELECTING EXPRESSION ';
errmess50[ 6] := 'PREV. STATEMENT MISSING ";","END","ELSE"OR"UNTIL" ';
errmess50[ 7] := 'NOT ALLOWED IN INITPROCEDURES (PACKED STRUCTURE?) ';
errmess50[ 8] := 'GOTO INTO MAIN PROGRAM NOT ALLOWED IF "EXTERN" ';
errmess50[ 9] := 'ASSIGNMENT TO FUNCTION NOT ALLOWED ON THIS LEVEL ';
errmess50[10] := 'NO STD- OR FORTRAN-PROC/FUNC AS ACTUAL-PROC/FUNC ';
errmess55[ 1] := 'FUNCTION RESULT TYPE MUST BE SCALAR,SUBRANGE OR POINTER';
errmess55[ 2] := 'REPETITION OF RESULT TYPE NOT ALLOWED IF FORW. DECL. ';
errmess55[ 3] := 'REPETITION OF PARAMETER LIST NOT ALLOWED IF FORW. DECL.';
errmess55[ 4] := 'NUMBER OF PARAMETERS DOES NOT AGREE WITH DECLARATION ';
errmess55[ 5] := 'RESULT TYPE OF PARAMETER-FUNC DOES NOT AGREE WITH DECL.';
errmess55[ 6] := 'SELECTED EXPRESSION MUST HAVE TYPE OF CONTROL VARIABLE ';
errmess55[ 7] := 'TOO MANY FILES OR TOO BIG FILE ELEMENTS. USE PASCAL. ';
errmess55[ 8] := 'ALREADY DECLARED. PREVIOUS DECLARATION WAS NOT FORWARD ';
END (*ERROR MESSAGES*) ;
INITPROCEDURE (*PCREF OPTION NAMES*) ;
(* 4. TO BE ABLE TO PASS THEM TO PCREF *)
BEGIN
pcrefoption_name [ 1] := 'CROSS ';
pcrefoption_name [ 2] := 'VERSION ';
pcrefoption_name [ 3] := 'WIDTH ';
pcrefoption_name [ 4] := 'INDENT ';
pcrefoption_name [ 5] := 'INCREMENT ';
pcrefoption_name [ 6] := 'DOTS ';
pcrefoption_name [ 7] := 'NODOTS ';
pcrefoption_name [ 8] := 'HEAD ';
pcrefoption_name [ 9] := 'NOHEAD ';
pcrefoption_name [10] := 'LINES ';
pcrefoption_name [11] := 'BEGIN ';
pcrefoption_name [12] := 'FORCE ';
pcrefoption_name [13] := 'NOFORCE ';
pcrefoption_name [14] := 'RES ';
pcrefoption_name [15] := 'NONRES ';
pcrefoption_name [16] := 'COMM ';
pcrefoption_name [17] := 'STR ';
pcrefoption_name [18] := 'CASE ';
END (*PCREF OPTION NAMES*) ;
(*----------------------------------------------------------------------------*)
(* INIT_COMPILE, PUTADR, LOCATION, INITPASSGO, ERROR *)
PROCEDURE init_compile;
BEGIN (* INIT_COMPILE *)
%13 program_count := program_count + 1; (* 14.*) \
programname := ' ';
currname := ' '; (* 27.*)
forward_pointer_type := NIL; (* 13. LASTBTP REPEATED BELOW.*)
fglobptr := NIL; fileptr := sfileptr;
localpfptr := NIL; declscalptr := sdeclscalptr;
globtestp := NIL; last_label := NIL;
errmptr := NIL; parmptr := NIL;
backwparmptr := NIL; externpfptr := sexternpfptr;
lastbtp := slastbtp; sstringlength := NIL; (* 25.*)
loadnoptr := true; initglobals := false;
followerror := false; errorinline := false;
dp := true; search_error := true;
errorflag := false; overrun := false;
errorexit := false; ttyread := false;
%13 entry_done := false; \ first_symbol := true;
reset_possible := true; incondcomp := false;
outputwrite := false; inputpar := false; (* 13.*)
outputpar := false; (* 13.*) parsingparameters := false; (* 25.*)
sstringstart := false; (* 25.*) errorinfirst := false; (* 30.*)
counting := false; (* 28.*) errorinlast := true; (* 30.*)
genprocfile := false;
%13 ic := high_start; lc := low_start; (* 14.*) \
%13 library_index := 0; (* 17.*) \ errinx := 0;
errorcount := 0; entries := 0;
debugentry.standardidtree := 0; debugentry.globalidtree := 0;
jumper := 0; jump_address := 0;
aos := b0; %24 INITPROCCOUNT := -1; (* 24.*) \
symcnt := 0; (* 30.*) lastchcnt := 0;
FOR i := 1 TO 18 DO
arraybps[i].state := unused;
arraybps[7].state := requested;
FOR i := 1 TO stdchcntmax DO
BEGIN
errline[i] := ' ';
lastbuffer[i] := ' ';
END;
%13 (* 19.*)
FOR support_index := first(support_index) TO last(support_index) DO
runtime_support.link[support_index] := 0;
(* 19.*) \
%13 relocation_block.count := 0; (* 18.*) \
top := 1; level := 1;
WITH display[1] DO
BEGIN
fname := NIL; occur := blck
END;
WHILE externpfptr <> NIL DO
WITH externpfptr↑ DO
BEGIN
linkchain[0] := 0; externpfptr := pfchain
END;
externpfptr := sexternpfptr;
WHILE declscalptr <> NIL DO
WITH declscalptr↑ DO
BEGIN
vectoraddr := 0; vectorchain := 0;
request := false; declscalptr := nextscalar
END;
declscalptr := sdeclscalptr;
WHILE lastbtp <> NIL DO
WITH lastbtp↑ DO
BEGIN
arraysp↑.arraybpaddr := 0; lastbtp := last
END;
lastbtp := slastbtp
END (* INIT_COMPILE *);
%24 (* 15. NEEDED TO INITIALIZE PASSGO.*)
PROCEDURE PUTADR(VAR A1, A2: EXTADDRVECTOR; VAR B: SUPPORTADDRARRAY);
EXTERN;
FUNCTION LOCATION (VAR C: INTEGER): INTEGER;
EXTERN;
FUNCTION LOCATIONOFAFILE (VAR F: TEXT): INTEGER;
EXTERN;
PROCEDURE INITPASSGO;
VAR
I: INTEGER;
BEGIN (* INITPASSGO *)
PUTADR (EXTADDR[DECLPROC], EXTADDR[DECLFUNC], RUNTIME_SUPPORT.LINK);
USERAREASTART := LOCATION(USERPROG.EXECODE[0]);
FILELC := LOW_START + USERAREASTART;
IC := USERAREASTART + MAXFILECODE;
LC := LOCATION(I);
DATASTART := LC;
END (* INITPASSGO *);
(* 15.*) \
PROCEDURE error(ferrnr: integer);
VAR
lpos,larw : integer;
BEGIN (*ERROR*)
IF NOT followerror THEN
BEGIN
errorcount := errorcount + 1; (* 13. KEEP THE ERRORS COUNTED RIGHT.*)
errorflag := true ;
IF errinx >= maxerr THEN
BEGIN
errlist[maxerr].nmr := 410; errinx := maxerr
END
ELSE
BEGIN
errinx := errinx + 1;
WITH errlist[errinx] DO
BEGIN
nmr := ferrnr; tic := '↑'
END
END;
followerror := true; errorinline := true;
IF symcnt = 1 THEN (* 30.*)
errorinfirst := true;
IF (ferrnr <> 214) AND (ferrnr <> 356) AND (ferrnr <> 405) AND
(ferrnr <> 465) AND (ferrnr <> 467) AND (ferrnr <> 264) AND
(ferrnr <> 267) THEN
IF eoln(source) THEN errline [chcnt] := '↑'
ELSE errline [chcnt-1] := '↑'
ELSE errlist[errinx].tic := ' ';
IF errinx > 1 THEN WITH errlist [ errinx-1] DO
BEGIN
lpos := pos; larw := arw
END;
WITH errlist [errinx] DO
BEGIN
pos := chcnt;
IF errinx = 1 THEN arw := 1
ELSE
IF lpos = chcnt THEN arw := larw
ELSE arw := larw + 1
END
END
END (*ERROR*) ;
(*SYMBOL TABLE INIT: ENTERID, ENTERSTDTYPES, ENTERSTDNAMES, ENTERUNDECL*)
PROCEDURE enterid(fcp: ctp);
(*ENTER ID POINTED TO BY FCP INTO THE NAME-TABLE,
WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
AN UNBALANCED BINARY TREE*)
VAR
new_name: alfa; lcp, lcp1: ctp; lleft: boolean;
BEGIN (*ENTERID*)
lcp := display[top].fname;
IF lcp = NIL THEN display[top].fname := fcp
ELSE
BEGIN
new_name := fcp↑.name;
REPEAT
lcp1 := lcp;
IF lcp↑.name <= new_name THEN
BEGIN
IF lcp↑.name = new_name THEN (*NAME CONFLICT*)
IF new_name[1] IN digits THEN error(266) (*MULTI-DECLARED LABEL*)
ELSE error(302) (*MULTI-DECLARED IDENTIFIER*) ;
lcp := lcp↑.rlink; lleft := false
END
ELSE
BEGIN
lcp := lcp↑.llink; lleft := true
END
UNTIL lcp = NIL;
IF lleft THEN lcp1↑.llink := fcp
ELSE lcp1↑.rlink := fcp
END;
WITH fcp↑ DO
BEGIN
llink := NIL; rlink := NIL; selfctp := NIL
END
END (*ENTERID*) ;
PROCEDURE enterstdtypes;
VAR
llcp, lcp: ctp;
PROCEDURE enterstdstring(VAR stringptr: stp; lowbnd, highbnd: integer);
VAR
lbtp: btp; lsp: stp;
BEGIN (*ENTERSTDSTRING*)
new(lsp,subrange);
WITH lsp↑ DO
BEGIN
rangetype := intptr; vmin.ival := lowbnd; vmax.ival := highbnd;
selfstp := NIL; size := 1; bitsize := bitmax
END;
new(stringptr,arrays);
WITH stringptr↑ DO
BEGIN
arraypf := true; arraybpaddr := 0; selfstp := NIL;
aeltype := asciiptr; inxtype := lsp; size := (highbnd-lowbnd+5) DIV 5;
bitsize := bitmax
END;
new(lbtp);
WITH lbtp↑ DO
BEGIN
last := lastbtp; arraysp := stringptr;
bitsize := 7; lastbtp := lbtp
END;
WITH arraybps[7], abyte DO
BEGIN
sbits := 7; pbits := bitmax; dummybit := 0;
ibit := 0; ireg := reg1; reladdr := 0;
bytemax := 6; state := requested
END
END;
BEGIN (*ENTERSTDTYPES*)
new(intptr,scalar,standard); (*INTEGER*)
WITH intptr↑ DO
BEGIN
size := 1;bitsize := bitmax; selfstp := NIL
END;
new(realptr,scalar,standard); (*REAL*)
WITH realptr↑ DO
BEGIN
size := 1;bitsize := bitmax; selfstp := NIL
END;
new(asciiptr,scalar,standard); (*ASCII*)
WITH asciiptr↑ DO
BEGIN
size := 1;bitsize := 7; selfstp := NIL
END;
new(boolptr,scalar,declared); (*BOOLEAN*)
WITH boolptr↑ DO
BEGIN
size := 1;bitsize := 1; selfstp := NIL
END;
new(nilptr,pointer); (*NIL*)
WITH nilptr↑ DO
BEGIN
eltype := NIL; size := 1; bitsize := 18; selfstp := NIL
END;
new(anyfileptr,files); (*"ANY FILE"*)
WITH anyfileptr↑ DO
BEGIN
filtype := NIL; size := 0; bitsize := 0; selfstp := NIL
END;
new(charptr,subrange); (*CHAR*)
WITH charptr↑ DO
BEGIN
size := 1; bitsize := 7; selfstp := NIL;
rangetype := asciiptr; vmin.ival := ord(' ');
vmax.ival := ord('_')
END;
new(textptr,files); (*TEXT*)
WITH textptr↑ DO
BEGIN
filtype := charptr; size := 1+sizeoffileblock; bitsize := bitmax;
file_mode := ascii_mode; filepf := true; selfstp := NIL;
file_form := text_file;
END;
enterstdstring(alfaptr,1,alfalength);
enterstdstring(packc9ptr,1,9);
enterstdstring(packc8ptr,1,8);
enterstdstring(packc6ptr,1,6);
enterstdstring(packc5ptr,1,5);
enterstdstring(packc3ptr,1,3);
slastbtp := lastbtp;
(* 25. STANDARD TYPES NEEDED FOR THE STRING PACKAGE.*)
IF stringpack THEN
BEGIN
enterstdstring(packc135ptr,1,135);
enterstdstring(packc1ptr,1,1);
enterstdstring(packc0ptr,1,0);
new(strgrngptr, subrange); (* STRGRANGE *)
WITH strgrngptr↑ DO
BEGIN
size := 1; bitsize := bitmax; selfstp := NIL;
rangetype := intptr; vmin.ival := 1; vmax.ival := strglgth;
END;
new(strgrng0ptr, subrange); (* STRGRANGE0 *)
WITH strgrng0ptr↑ DO
BEGIN
size := 1; bitsize := bitmax; selfstp := NIL;
rangetype := intptr; vmin.ival := 0; vmax.ival := strglgth;
END;
new(lcp,field); (* STRING.STRTEXT *)
WITH lcp↑ DO
BEGIN
name := 'STRTEXT '; idtype := packc135ptr;
packf := notpack; fldaddr := 0;
END;
enterid(lcp);
llcp := lcp;
new(lcp, field); (* STRING.LEN *)
WITH lcp↑ DO
BEGIN
name := 'LEN '; idtype := strgrng0ptr; next := NIL;
packf := notpack; fldaddr := packc135ptr↑.size;
END;
llcp↑.next := lcp;
enterid(lcp);
new(sstringptr, records); (* STRING *)
WITH sstringptr↑ DO
BEGIN
selfstp := NIL; size := packc135ptr↑.size + 1; bitsize := bitmax;
recordpf := false; fstfld := llcp; recvar := packc135ptr;
END;
END;
END (*ENTERSTDTYPES*) ;
PROCEDURE enterstdnames;
VAR
cp: ctp;
i,j: integer;
lfileptr: ftp;
lcsp: csp;
%24 LLC: ADDRRANGE; (* 21.*) \
PROCEDURE enterstdprocfunc(findex: integer; fidclass: idclass; fidtype: stp; fnext: ctp);
VAR
i: integer; lcp: ctp; nameix: namekind;
BEGIN (*ENTERSTDPROCFUNC*)
IF fidclass = func THEN
BEGIN
nameix := declfunc; new(lcp,func,declared,actual)
END
ELSE
BEGIN
nameix := declproc; new(lcp,proc,declared,actual)
END;
WITH lcp↑ DO
BEGIN
idtype := fidtype; next := fnext; forwdecl := false; highest_register := stdparregcmax;
pflev := 0; pfaddr := 0; pfchain := externpfptr; externpfptr := lcp; externdecl := true;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
language := extlanguage[nameix,findex];
externalname := extna[nameix,findex]; name := na[nameix,findex];
%24 PFADDR := EXTADDR[NAMEIX, FINDEX]; (* 19. PASSGO KNOWS THEIR ADDRESS.*) \
END;
enterid(lcp)
END (*ENTERSTDPROCFUNC*);
PROCEDURE enterstdparameter(fidtype: stp; fidkind: idkind; fnext: ctp; faddr: integer);
BEGIN (*ENTERSTDPARAMETER*)
new(cp,vars);
WITH cp↑ DO
BEGIN
name := ' '; idtype := fidtype;
vkind := fidkind; next := fnext; vlev := 1; vaddr := faddr
END
END (*ENTERSTDPARAMETER*);
PROCEDURE enterstdid(fidclass: idclass; fname: alfa; fidtype: stp; fnext: ctp; fival: integer);
BEGIN (*ENTERSTDID*)
new(cp);
WITH cp↑ DO
BEGIN
klass := fidclass; name := fname; idtype := fidtype; next := fnext;
IF fidclass = konst THEN values.ival := fival
END;
enterid(cp)
END (*ENTERSTDID*);
BEGIN (*ENTERSTDNAMES*)
enterstdid(types,'INTEGER ',intptr,NIL,0);
enterstdid(types,'REAL ',realptr,NIL,0);
enterstdid(types,'CHAR ',charptr,NIL,0);
enterstdid(types,'ASCII ',asciiptr,NIL,0);
enterstdid(types,'BOOLEAN ',boolptr,NIL,0);
enterstdid(types,'TEXT ',textptr,NIL,0);
enterstdid(types,'ALFA ',alfaptr,NIL,0);
enterstdid(konst,'NIL ',nilptr,NIL,377777B);
enterstdid(konst,'ALFALENGTH',intptr,NIL,10);
enterstdid(konst,'MAXINT ',intptr,NIL,377777777777B);
enterstdid(konst,'MININT ',intptr,NIL,-maxint - 1);
new(lcsp,reel); lcsp↑.intval := 377777777777B;
enterstdid(konst,'MAXREAL ',realptr,NIL,ord(lcsp));
new(lcsp,reel); lcsp↑.intval := 400000000B;
enterstdid(konst,'SMALLREAL ',realptr,NIL,ord(lcsp));
cp := NIL;
FOR i := 1 TO 2 DO
enterstdid(konst,na[stdconst,i],boolptr,cp,i-1);
WITH boolptr↑ DO
BEGIN
fconst := cp; vectoraddr := 0; vectorchain := 0;
tlev := 0; request := false; nextscalar := NIL;
dimension := 1
END;
declscalptr := boolptr;
cp := NIL;
FOR i := 3 TO 35 DO
enterstdid(konst,na[stdconst,i],asciiptr,cp,i-3);
enterstdid(konst,na[stdconst,36],asciiptr,cp,177B);
(* 25. STRING,STRGRANGE,STRGRANGE0,MAXSTRLEN,NULLSTR: FOR THE STRING PACKAGE.*)
IF stringpack THEN
BEGIN
enterstdid(types,'STRING ', sstringptr, NIL, 0);
enterstdid(types,'STRGRANGE ', strgrngptr, NIL, 0);
enterstdid(types,'STRGRANGE0', strgrng0ptr, NIL, 0);
enterstdid(konst,'MAXSTRLEN ', strgrngptr, NIL, 135);
new(lcsp,strg:140);
enterstdid(konst,'NULLSTR ', packc0ptr, NIL, ord(lcsp));
END;
(*INPUT,OUTPUT,TTY,TTYOUTPUT*)
%24 LLC := LOCATIONOFAFILE (INPUT); (* 21.*) \
FOR i := 1 TO namax[stdfile] DO
BEGIN
new(cp,vars);
stdfileptr[i] := cp;
WITH cp↑ DO
BEGIN
name := na[stdfile,i]; idtype := textptr; channel := i-1;
vkind := actual; next := NIL; vlev := 0;
%13 (* 20.*)
vaddr:= lc;
lc:=lc+idtype↑.size;
(* 20.*) \
%24 (* 20.*)
VADDR := LLC;
LLC := LLC + IDTYPE↑.SIZE;
FILELC := FILELC + IDTYPE↑.SIZE;
(* 20.*) \
new(lfileptr) ;
WITH lfileptr↑ DO
BEGIN
nextftp := fileptr ;
fileident := cp
END ;
fileptr := lfileptr
END;
enterid(cp)
END;
(* GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
WRITE,WRITELN,PACK,UNPACK,NEW,GETLINR,
PAGE,PROTECTION,RUN,DATE,TIME,DISPOSE,
HALT,GETSEG,PUTSEG,MESSAGE,LINELIMIT*)
FOR i := 1 TO namax[stdproc] DO
BEGIN
new(cp,proc,standard);
WITH cp↑ DO
BEGIN
name := na[stdproc,i]; idtype := NIL;
next := NIL; key := i
END;
enterid(cp)
END;
(* CLOCK,ABS,SQR,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN,REALTIME,CARD,
LOWERBOUND,UPPERBOUND,MIN,MAX,FIRST,LAST,EOS*)
FOR i := 1 TO namax[stdfunc] DO
BEGIN
new(cp,func,standard);
WITH cp↑ DO
BEGIN
name := na[stdfunc,i]; idtype := NIL;
next := NIL; key := i
END;
enterid(cp)
END;
(* COS,EXP,SQRT,ALOG,ATAN,ALOG10,
SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN,SIN*)
enterstdparameter(realptr,actual,NIL,2);
FOR i := 1 TO 15 DO enterstdprocfunc(i,func,realptr,cp);
(* ROUND, EXPO *)
enterstdprocfunc(16,func,intptr,cp);
enterstdprocfunc(17,func,intptr,cp);
(* OPTION *)
enterstdparameter(alfaptr,actual,NIL,2);
enterstdprocfunc(18,func,boolptr,cp);
(* TRUNC *)
enterstdparameter(realptr,actual,NIL,2);
enterstdprocfunc(20,func,intptr,cp);
(* GETFILENAME *)
enterstdparameter(alfaptr,actual,NIL,6);
enterstdparameter(packc6ptr,formal,cp,5);
enterstdparameter(intptr,formal,cp,4);
enterstdparameter(intptr,formal,cp,3);
enterstdparameter(packc9ptr,formal,cp,2);
enterstdparameter(anyfileptr,formal,cp,1);
enterstdprocfunc(1,proc,NIL,cp);
(* GETOPTION *)
enterstdparameter(intptr,formal,NIL,4);
enterstdparameter(alfaptr,actual,cp,2);
enterstdprocfunc(2,proc,NIL,cp);
(* GETSTATUS *)
enterstdparameter(packc6ptr,formal,NIL,5);
enterstdparameter(intptr,formal,cp,4);
enterstdparameter(intptr,formal,cp,3);
enterstdparameter(packc9ptr,formal,cp,2);
enterstdparameter(anyfileptr,formal,cp,1);
enterstdprocfunc(3,proc,NIL,cp);
(* 7. KNOW ABOUT NEW RUNTIMES IN CCL SCANNER.*)
(*ASKFILENAME*)
enterstdparameter (asciiptr, formal, NIL, 11);
enterstdparameter (boolptr, formal, cp, 10);
enterstdparameter (boolptr, actual, cp, 9);
enterstdparameter (alfaptr, actual, cp, 7);
enterstdparameter (alfaptr, actual, cp, 5);
enterstdparameter (packc6ptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (intptr, formal, cp, 2);
enterstdparameter (packc9ptr, formal, cp, 1);
enterstdprocfunc (4, proc, NIL, cp);
(*STARTFILE*)
enterstdparameter (packc3ptr, actual, NIL, 9);
enterstdparameter (alfaptr, actual, cp, 7);
enterstdparameter (boolptr, actual, cp, 6);
enterstdparameter (packc6ptr, formal, cp, 5);
enterstdparameter (intptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (packc9ptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (5,proc, NIL, cp);
(*GETPARAMETER*)
enterstdparameter (boolptr, actual, NIL, 4);
enterstdparameter (alfaptr, formal, cp, 3);
enterstdparameter (alfaptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (6, proc, NIL, cp);
(*GETNEXTCALL*)
enterstdparameter (packc6ptr, formal, NIL, 2);
enterstdparameter (packc9ptr, formal, cp, 1);
enterstdprocfunc (7, proc, NIL, cp);
(*FILNAM*)
enterstdparameter (boolptr, formal, NIL, 9);
enterstdparameter (boolptr, formal, cp, 8);
enterstdparameter (boolptr, actual, cp, 7);
enterstdparameter (alfaptr, actual, cp, 5);
enterstdparameter (packc6ptr, formal, cp, 4);
enterstdparameter (intptr, formal, cp, 3);
enterstdparameter (packc9ptr, formal, cp, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (8, proc, NIL, cp);
(*REENTER, SETTIME*)
enterstdprocfunc (9, proc, NIL, NIL);
enterstdprocfunc (10, proc, NIL, NIL);
(*TIMEREPORT*)
enterstdparameter (alfaptr, actual, NIL, 2);
enterstdparameter (anyfileptr, formal, cp, 1);
enterstdprocfunc (11, proc, NIL, cp);
(*RUNTIME*)
enterstdparameter (alfaptr, formal, NIL, 1);
enterstdprocfunc (12, proc, NIL, cp);
(*ELAPSEDTIME*)
enterstdparameter (alfaptr, formal, NIL, 1);
enterstdprocfunc (13, proc, NIL, cp);
(* 25. FOR THE STRING PACKAGE: *)
IF stringpack THEN
BEGIN
(* LENGTH *)
enterstdparameter(sstringptr,actual,NIL,2);
enterstdprocfunc(21,func,strgrngptr,cp);
(* GETCHAR *)
enterstdparameter(strgrngptr,actual,NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(22,func,charptr,cp);
(* POS *)
enterstdparameter(sstringptr,actual,NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(23,func,intptr,cp);
(* STRLT, STRLE, STREQ, STRGE, STRGT, STRNE *)
FOR i := 24 TO 29 DO
BEGIN
enterstdparameter(sstringptr,actual, NIL,30);
enterstdparameter(sstringptr,actual,cp,2);
enterstdprocfunc(i,func,boolptr,cp);
END;
(* PUTCHAR *)
enterstdparameter(strgrngptr,actual,NIL,3);
enterstdparameter(sstringptr,formal,cp,2);
enterstdparameter(charptr,actual,cp,1);
enterstdprocfunc(14,proc,NIL,cp);
(* ASSIGN *)
enterstdparameter(sstringptr,formal,NIL,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(15,proc,NIL,cp);
(* SUBSTR *)
enterstdparameter(intptr,actual,NIL,32);
enterstdparameter(intptr,actual,cp,31);
enterstdparameter(intptr,actual,cp,30);
enterstdparameter(sstringptr,formal,cp,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(16,proc,NIL,cp);
(* CONCAT *)
enterstdparameter(sstringptr,formal,NIL,29);
enterstdparameter(sstringptr,actual,cp,1);
enterstdprocfunc(17,proc,NIL,cp);
END;
(* SETRAN *)
enterstdparameter(intptr,actual,NIL,1);
enterstdprocfunc(18,proc,NIL,cp);
sexternpfptr := externpfptr;
sfileptr := fileptr;
sdeclscalptr := declscalptr;
lcmain := lc
END (*ENTERSTDNAMES*) ;
PROCEDURE enterundecl;
VAR
i: integer;
BEGIN (*ENTERUNDECL*)
new(utypptr,types);
WITH utypptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL
END;
new(ucstptr,konst);
WITH ucstptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL;
values.ival := 0
END;
new(uvarptr,vars);
WITH uvarptr↑ DO
BEGIN
name := ' '; idtype := NIL; vkind := actual;
next := NIL; vlev := 0; vaddr := 0
END;
new(ufldptr,field);
WITH ufldptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL; fldaddr := 0;
packf := notpack
END;
new(uprcptr,proc,declared,actual);
WITH uprcptr↑ DO
BEGIN
name := ' '; idtype := NIL; forwdecl := false;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
next := NIL; externdecl := false; pflev := 0; pfaddr := 0
END;
new(ufctptr,func,declared,actual);
WITH ufctptr↑ DO
BEGIN
name := ' '; idtype := NIL; next := NIL;
FOR i := 0 TO maxlevel DO linkchain[i] := 0;
forwdecl := false; externdecl := false; pflev := 0; pfaddr := 0
END
END (*ENTERUNDECL*) ;
(*GET_DIRECTIVES*)
PROCEDURE get_directives;
(* 23. USE THE PROCEDURES FROM THE LIBRARY, TO GUARANTEE CONSISTENCY OF FUTURE CHANGES.*)
CONST
%13 myname = 'PASCAL '; \
%24 MYNAME = 'PASSGO '; \
VAR
%13 object_protection , object_ufd, (* 14.*) \
source_protection , source_ufd: integer;
%13 object_device: PACKED ARRAY[1..6] OF char; (* 14.*) \
fromtmpfile: boolean;
brkchar: char;
%24 LASTCH: CHAR; (* 14.*) \
BEGIN (*GET_DIRECTIVES*)
%13 (* 14.*)
askfilename(object_file,object_protection,object_ufd,object_device, (* GET THE FILE NAMES.*)
'OBJECT ',myname,false,fromtmpfile,brkchar);
(* 14.*) \
%3
IF brkchar <> '=' THEN BEGIN \
askfilename(list_file,list_protection,list_ufd,list_device,
'LIST ',myname,false,fromtmpfile,brkchar);
%3 END
ELSE
BEGIN
list_file := ' '; list_device := 'DSK ';
END;
\
%2 IF BRKCHAR = ',' THEN
ASKFILENAME(LIST_FILE,LIST_PROTECTION,LIST_UFD,LIST_DEVICE,
'LIST ',MYNAME,FALSE,FROMTMPFILE,BRKCHAR);
\
askfilename(source_file,source_protection,source_ufd,source_device,
'SOURCE ',myname,true,fromtmpfile,brkchar);
IF (source_file[1] = ' ') AND (source_device = 'DSK ') THEN (* OPEN SOURCE FILE.*)
source_file := 'SOURCE ';
startfile (source, source_file, source_protection, source_ufd,
source_device, true, 'SOURCE ', %13 'PAS' \ %24 'PGO' \ );
%3
IF object_protection = 0 THEN
object_protection := 400B;
(*NO DUMP OF .REL FILES. EJG 20-JAN-79*)
\
%13 (* 14.*) (* 11. DEFAULT THE OBJECT FILE NAME IF NEEDED.*)
IF (object_file [1] = ' ') AND (object_device = 'DSK ') THEN (* OPEN OBJECT FILE.*)
IF source_file = 'SOURCE ' THEN
object_file := 'OBJECT '
ELSE
FOR i := 1 TO 6 DO
object_file[i] := source_file[i];
startfile(object,object_file,object_protection,object_ufd,
object_device,false,'OBJECT ','REL');
(* 14.*) \
cross_reference := option('CREF ') OR option('C ') ; (* OPEN LIST FILE, IF REQUESTED.*)
counting := option('PROFILE ') OR option('KNT ') OR option ('K '); (* 28.*)
%13 cross_reference := cross_reference AND NOT counting; \
%24 CROSS_REFERENCE := CROSS_REFERENCE OR COUNTING; \
%13 list_code := option('CODE '); (* 14.*) \
logfile := option ('LOG ');
lptfile := NOT option('NOLIST ') AND (NOT cross_reference) AND
(NOT counting) AND
( %13 list_code OR (* 14.*) \
option('LPT ') OR
option('LIST ') OR
(list_file <> ' ') OR
(list_device <> 'DSK ')); (* 9.*)
(* 11. DEFAULT THE LIST FILE NAME IF NEEDED.*)
IF lptfile THEN
BEGIN
IF (list_file [1] = ' ') AND (list_device = 'DSK ') THEN
FOR i := 1 TO 6 DO
list_file[i] := source_file[i];
startfile(list,list_file,list_protection,list_ufd,list_device,
false,'LIST ','LST');
logfile := false;
END
ELSE
IF logfile THEN
BEGIN
FOR i := 1 TO 6 DO
list_file[i] := source_file[i];
list_file[7] := 'L'; list_file[8] := 'O'; list_file[9] := 'G';
startfile(list,list_file,list_protection,list_ufd,list_device,
false,'LOGFILE ','LOG');
END;
debug := option('DEBUG ') OR option ('D '); (* 13.*) (* CHECK SWITCHES.*)
debug_switch := debug;
runtime_check := NOT option('NOCHECK ');
genprocfile := option('PRC ');
resettty := NOT option ('NOTTY ');
openoutput := NOT option ('NOOUTPUT ');
IF option('CODESIZE ') THEN getoption('CODESIZE ',code_size);
IF option('REGISTER ') THEN
BEGIN
getoption('REGISTER ',i);
IF i IN [regin..within] THEN parregcmax := i
END;
(* 8. ALLOW FOR SWITCH /VERSION.*)
IF option ('VERSION ') THEN
getoption ('VERSION ',goodversion);
%13 (* 14. SWITCHES PARTICULAR TO PASCAL AND ITS VERSION OF LOAD_AND_GO CHECKING.*)
fortran_enviroment := option('FORTIO ');
external := option('EXTERN ');
IF option('RUNCORE ') THEN getoption('RUNCORE ',runcore);
IF option('CARD ') THEN chcntmax := 72;
IF option('FILE ') THEN
BEGIN
getoption('FILE ',i);
IF i IN [1..max_file] THEN start_channel := i + namax[stdfile] - 2
END;
(* 1. IF A LINKER NAME CAME IN THE TEMPCORE FILE, LOAD_AND_GO.*)
IF fromtmpfile THEN (* ONLY IF A TMPCORE FILE WAS SUPPLIED.*)
BEGIN
getnextcall(linker_file,link_device);
IF linker_file = 'LOADER ' THEN
BEGIN
\
%3 link_device := 'SYS '; \
%13
loadit := true;
link_tmpfile := 'LOA TMP';
END
ELSE
BEGIN
IF (linker_file = 'LINK ') OR (linker_file = 'LINK10 ') THEN
BEGIN
\
%3 link_device := 'SYS '; \
%13
loadit := true;
link_tmpfile := 'LNK TMP';
END
ELSE (* NO LEGAL LINKER NAME.*)
link_tmpfile := ' ';
END;
END;
load_and_go := option('EXECUTE ') OR (counting AND NOT option ('NOEXECUTE '));
loadit := loadit OR (option ('LINK ') OR
load_and_go OR option ('LOAD '))
AND NOT external;
\
%1
RESET(TEMPCORE,LINK_TMPFILE); (* CHECK FOR THE DEBUG SWITCH IN THE TEMPFILE FOR THE LINKER *)
IF NOT EOF(TEMPCORE) THEN
BEGIN
NEW(COMMAND_BUFFER:BUFFER_SIZE);
COMMAND_BUFFER↑[0] := ' '; I := 1;
WHILE NOT EOF(TEMPCORE) AND (I < BUFFER_SIZE) DO
BEGIN
IF EOLN(TEMPCORE) THEN
BEGIN
READLN(TEMPCORE);
COMMAND_BUFFER↑[I] := CR;
COMMAND_BUFFER↑[I+1] := LF; I := I + 2
END
ELSE (* NOT EOLN(TEMPCORE) *)
BEGIN
READ(TEMPCORE,CH);
COMMAND_BUFFER↑[I] := CH;
IF (COMMAND_BUFFER↑[I-1] = '/') AND (CH = 'D') THEN
BEGIN
DEBUG := TRUE; DEBUG_SWITCH := TRUE;
(* 13. GET RID OF THE REST OF THE STANDARD SWITCH, /DEBUG:PASCAL*)
WHILE CH IN ['A'..'Z',':'] DO
READ (TEMPCORE, CH);
COMMAND_BUFFER↑[I-1] := CH;
END
ELSE I := I + 1
END
END;
REWRITE(TEMPCORE,LINK_TMPFILE);
WRITE(TEMPCORE,COMMAND_BUFFER↑:I);
DISPOSE(COMMAND_BUFFER:BUFFER_SIZE)
END
ELSE (* EOF(TEMPCORE) *)
BEGIN
IF LOADIT THEN
BEGIN
REWRITE(TEMPCORE,LINK_TMPFILE); (* 1. FLEXIBLE NAME OF LINKER.*)
WRITE(TEMPCORE,'DSK:',OBJECT_FILE:6);
IF LOAD_AND_GO THEN
WRITE(TEMPCORE,' /E');
WRITE(TEMPCORE,'/G'); (* 1. MORE CORRECT ORDERING.*)
END
END;
(* 14.*) \
%24 (* 14. PASSGO VERSION OF THE LOAD_AND_GO CHECKING.*)
IF FROMTMPFILE THEN
BEGIN
GETNEXTCALL(LINKER_FILE, LINK_DEVICE); (* SEE IF ANY LOADER WAS INVOKED *)
IF LINKER_FILE = ' ' THEN
NO_CODE_GEN := TRUE
ELSE
BEGIN
IF (LINKER_FILE = 'LOADER ') OR (LINKER_FILE = 'LOADEREXE') THEN
LINK_TMPFILE := 'LOA TMP'
ELSE
IF (LINKER_FILE[1] = 'L') AND (LINKER_FILE[2] = 'I') AND
(LINKER_FILE[3] = 'N') AND (LINKER_FILE[4] = 'K') THEN
LINK_TMPFILE := 'LNK TMP';
RESET(TEMPCORE,LINK_TMPFILE); (* CHECK FOR THE DEBUG SWITCH IN THE TEMPFILE FOR THE LOADER *)
IF NOT EOF(TEMPCORE) THEN
BEGIN
LASTCH := ' ';
WHILE NOT EOF(TEMPCORE) DO
BEGIN
IF EOLN(TEMPCORE) THEN
READLN(TEMPCORE)
ELSE (* NOT EOLN(TEMPCORE) *)
BEGIN
READ(TEMPCORE,CH);
IF (LASTCH = '/') AND (CH = 'D') THEN
BEGIN
DEBUG := TRUE; DEBUG_SWITCH := TRUE;
END;
LASTCH := CH;
END
END;
END
END;
END;
(* 14.*) \
END (*GET_DIRECTIVES*);
PROCEDURE startlog;
BEGIN
END (*STARTLOG*);
(* COMPILE[ NEWPAGER, WRITEBUFFER, GETNEXTLINE, FINISHLINE, ERROR_WITH_TEXT, WARNING*)
PROCEDURE compile;
LABEL
111;
VAR
escape: boolean;
PROCEDURE newpager;
BEGIN (*NEWPAGER*)
WITH pager, word1 DO
BEGIN
ac := pagecnt DIV 16;
inxreg := pagecnt MOD 16; address := lastpager;
lhalf := lastline; rhalf := laststop;
lastline := -1
END
END (*NEWPAGER*);
%13 (* 14. LIST_CODE IS NOT IN PASSGO.*)
PROCEDURE writebuffer;
BEGIN (*WRITEBUFFER*)
IF list_code THEN
BEGIN
writeln(list,buffer:chcnt); FOR chcnt := 1 TO 17 DO buffer[chcnt] := ' ';
chcnt := 17
END
END (*WRITEBUFFER*);
(* 14.*) \
PROCEDURE getnextline;
BEGIN (*GETNEXTLINE*)
LOOP
getlinenr(source,linenr);
IF reset_possible THEN
hassoslines := linenr <> '-----';
EXIT IF (linenr <> ' ') OR eof(source);
linecnt := 1;
line500 := 1;
IF debug AND (lastline > -1) THEN newpager;
pagecnt := pagecnt + 1;
IF lptfile THEN
BEGIN
page(list); writeln(list,header,' COMPILATION LIST PRODUCED ON ',day,
' AT ',timeofday,' PAGE ',pagecnt:3); writeln(list)
END;
(* 6. GIVE PAGENUMBERS ON TTY.*)
IF programname <> ' ' THEN
BEGIN
write (tty, pagecnt:3, '..');
break (tty);
needsaneoln := true;
END;
readln(source) (*TO OVERREAD SECOND <LF> IN PAGE MARK*)
END;
%13 (* 14. LIST_CODE IS NOT IN PASSGO.*)
IF list_code THEN
BEGIN
IF dp THEN write(list,lc:6:o,showrelo[(lc >= low_start) AND (level <= 1)])
ELSE write(list,ic:6:o,'''');
write(list,' ':2)
END;
(* 14.*) \
IF lptfile THEN
BEGIN
IF NOT hassoslines THEN write(list,linecnt:5)
ELSE write(list,linenr) ;
write(list,' ':3)
END
END (*GETNEXTLINE*);
PROCEDURE finishline;
VAR
llptfile: boolean;
i,k: integer;
BEGIN (*FINISHLINE*)
tchcnt := tchcnt + chcnt;
IF chcnt > chcntmax THEN chcnt := chcntmax;
IF lptfile THEN writeln(list,buffer:chcnt);
IF errorinline THEN (*OUTPUT ERROR MESSAGES*)
BEGIN
IF needsaneoln THEN
BEGIN
writeln(tty);
needsaneoln := false;
END;
%13 (* 14.*)
IF list_code THEN
k := 11
ELSE
(* 14.*) \
k := 2;
IF lptfile THEN writeln(list,' ':k,'***** ',errline : chcnt)
ELSE
IF logfile THEN
BEGIN
IF errorinfirst AND NOT errorinlast THEN
writeln(list,'-------- ',lastbuffer:lastchcnt);
IF hassoslines THEN
write(list,linenr)
ELSE
write(list,linecnt:5);
writeln(list,'/',pagecnt:2,' ',buffer:chcnt);
writeln(list,currname,errline:chcnt)
END;
%13 list_code := false; (* 14.*) \
IF errorinfirst AND NOT errorinlast THEN
writeln(tty,'-------- ',lastbuffer:lastchcnt);
IF NOT hassoslines THEN (* 27.*)
write(tty,linecnt:5)
ELSE write(tty,linenr);
(* 13.*)
writeln(tty,'/',pagecnt:2,' ',buffer:chcnt);
writeln(tty,currname,errline : chcnt);
llptfile := lptfile OR logfile;
FOR k := 1 TO errinx DO
WITH errlist[k] DO
BEGIN
IF llptfile THEN write(list,' ':15,arw:1,'.',tic,': ');
write(tty,arw:1,'.',tic,': ');
IF errmptr <> NIL THEN
BEGIN
errmptr1 := errmptr;
REPEAT
WITH errmptr1↑ DO
IF nmr = number THEN
BEGIN
IF msgkind = intmsg THEN
BEGIN
IF llptfile THEN
write(list,intval,' - ');
write(tty,intval,' - ');
END
ELSE (*MSGKIND = ALFAMSG*)
BEGIN
IF llptfile THEN write(list,string:10,' - ');
write(tty,string:10,' - ');
END;
number := 0; errmptr1 := NIL
END
ELSE errmptr1 := next
UNTIL errmptr1 = NIL
END;
i := nmr MOD 50;
CASE nmr DIV 50 OF
3:
BEGIN
IF llptfile THEN write(list,errmess15[i]);
write(tty,errmess15[i])
END;
4:
BEGIN
IF llptfile THEN write(list,errmess20[i]);
write(tty,errmess20[i])
END;
5:
BEGIN
IF llptfile THEN write(list,errmess25[i]);
write(tty,errmess25[i])
END;
6:
BEGIN
IF llptfile THEN write(list,errmess30[i]);
write(tty,errmess30[i])
END;
7:
BEGIN
IF llptfile THEN write(list,errmess35[i]);
write(tty,errmess35[i])
END;
8:
BEGIN
IF llptfile THEN write(list,errmess40[i]);
write(tty,errmess40[i])
END;
9:
BEGIN
IF llptfile THEN write(list,errmess45[i]);
write(tty,errmess45[i])
END;
10:
BEGIN
IF llptfile THEN write(list,errmess50[i]);
write(tty,errmess50[i])
END;
11:
BEGIN
IF llptfile THEN write(list,errmess55[i]);
write(tty,errmess55[i])
END
END (*CASE*);
IF errorinfirst THEN (* 30.*)
BEGIN
errorinfirst := false;
IF llptfile THEN
write(list,' *** CHECK ALSO PREVIOUS LINE ***');
write(tty,' *** CHECK ALSO PREVIOUS LINE ***');
END;
IF llptfile THEN writeln(list);
writeln(tty)
END;
errorinlast := true;
break(tty); errinx := 0; errorinline := false;
FOR i := 1 TO chcnt DO errline [i] := ' ';
errmptr := NIL
END (*IF ERRORINLINE*)
ELSE (*NOT ERRORINLINE*)
IF symcnt > 0 THEN
BEGIN
errorinlast := false;
lastbuffer := buffer;
lastchcnt := chcnt;
END (*NOT ERRORINLINE*);
readln(source);
linecnt := linecnt + 1; chcnt := 0; symcnt :=0;
line500 := line500 + 1;
IF programname <> ' ' THEN (* 27.*)
IF line500 = 500 THEN
BEGIN
write(tty,'(',linecnt:5,')');
break(tty);
needsaneoln := true;
line500 := 0;
END;
IF errorexit THEN
IF first_symbol THEN GOTO 0
ELSE GOTO 111
ELSE
BEGIN
IF NOT eof(source) THEN
getnextline
ELSE
BEGIN
IF NOT first_symbol THEN error(267);
errorexit := true;
finishline
END
END
END (*FINISHLINE*) ;
PROCEDURE error_with_text ( ferrnr: integer; ftext: alfa ) ;
BEGIN (*ERROR_WITH_TEXT*)
error(ferrnr); new(errmptr1,alfamsg);
WITH errmptr1↑ DO
BEGIN
number := ferrnr; string := ftext;
next := errmptr
END;
errmptr := errmptr1
END (*ERROR_WITH_TEXT*) ;
PROCEDURE error_valued(ferrnr, fint: integer);
BEGIN (*ERROR_VALUED*)
error(ferrnr); new(errmptr1,intmsg);
WITH errmptr1↑ DO
BEGIN
number := ferrnr; intval := fint;
next := errmptr;
END;
errmptr := errmptr1;
END (*ERROR_VALUED*);
PROCEDURE warning (ferrnr: integer);
BEGIN (* WARNING *)
error_with_text (ferrnr,' WARNING: ');
errorcount := errorcount - 1;
IF errorcount = 0 THEN
errorflag := false;
END (* WARNING *);
(*INSYMBOL[NEXTCH, SKIPCOMMENT[OPTIONS], SKIP_E_DIRECTORY*)
PROCEDURE insymbol;
(*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH*)
LABEL
111,222,333;
CONST
maxdigits = 12;
max8 = 37777777777B;
test8 = 40000000000B;
max10 = 3435973836; (* MAXINT = 2 ** 35 - 1 = 34.359.738.367 *)
max16 = 17777777777B;
test16 = 20000000000B;
maxexp2 = 127; (* MAXREAL = 777.777.777B * 2 ** 100 *)
log_of_2 = 0.30102999806;
VAR
i, k, scale, exponent, ival: integer;
rval, r, fac: real;
stringtoolong, sign: boolean;
digit: ARRAY [1..maxdigits] OF 0..9;
string: ARRAY [1..strglgth] OF char;
lvp: csp;
PROCEDURE nextch;
BEGIN (*NEXTCH*)
IF eoln(source) THEN ch := ' '
ELSE
BEGIN
ch := source↑; get(source);
chcnt := chcnt + 1;
IF chcnt <= chcntmax THEN buffer[chcnt] := ch
ELSE
IF chcntmax = 72 THEN nextch
END
END (*NEXTCH*);
(* 3. DISTINGUISH ONE-CHAR FROM TWO-CHAR LONG END OF COMMENT.*)
PROCEDURE skipcomment (onechar: boolean; endchar: char);
VAR
lcondcomp,
commentend: boolean;
PROCEDURE options;
(*PROCESSES THE OPTIONS INSIDE A COMMENT THAT STARTS WITH
A DOLLAR SIGN.*)
(*LETTERS LEFT: ABHJKMNQWZ*)
VAR
lch : char;
lswitch : boolean;
lvalue : integer;
BEGIN (*OPTIONS*)
REPEAT
lvalue := 0; lswitch := false;
nextch; lch := ch;
IF ch <> endchar THEN nextch;
IF ch IN (['+','-'] + digits) THEN
BEGIN
IF ch IN ['+','-'] THEN
BEGIN
lswitch := ch = '+'; nextch
END
ELSE
REPEAT
lvalue := lvalue * 10 + (ord(ch)-ord('0'));
nextch
UNTIL NOT (ch IN digits);
IF NOT reset_possible AND (lch IN ['S','R','X','F','I','U','E','V','Y','C','O','G']) THEN
error(203)(* 8. ALLOW FOR OPTION V AND Y.*) (* 28.*)
ELSE
CASE lch OF
%13 (* 14. SUPPRESSED FOR PASSGO.*)
'L':
list_code := lswitch AND lptfile;
'U':
IF lswitch THEN (* 13. ONLY IF IT IS 'U+'.*)
chcntmax := 72;
(* 14.*) \
'G':
IF lswitch AND NOT logfile AND NOT lptfile THEN
BEGIN
logfile := true;
FOR i := 1 TO 6 DO
list_file[i] := source_file[i];
list_file[7] := 'L'; list_file[8] := 'O'; list_file[9] := 'G';
startfile(list,list_file,list_protection,list_ufd,list_device,
false,'LOGFILE ','LOG');
END;
'T':
runtime_check := lswitch;
%13 (* 14. SUPPRESSED FOR PASSGO. *)
'E':
IF program_count > 1 THEN error(203)
ELSE
BEGIN
external := lswitch;
IF external THEN (* 13. CANCEL LOAD_AND_GO.*)
load_and_go := false;
END;
(* 14.*) \
'D' %13 ,'P' \ : (* 14.*)
IF reset_possible THEN
BEGIN
debug := lswitch;
debug_switch := lswitch
END
ELSE
IF debug THEN debug_switch := lswitch
ELSE error(203);
%13 (* 14. SUPPRESSED FOR PASGO.*)
'F':
IF lvalue IN [1..max_file] THEN start_channel := lvalue + namax[stdfile] - 2
ELSE error(203);
'R':
runcore := lvalue;
(* 14.*) \
'X':
IF lvalue IN [regin..within] THEN parregcmax := lvalue
ELSE error(203);
'S':
code_size := lvalue;
%13 (* 14. SUPPRESSED FOR PASSGO.*)
'I':
fortran_enviroment := lswitch;
(* 14.*) \
(* 8. SET THE VERSION NUMBER.*)
'V':
goodversion := lvalue;
'C': (* 28.*)
counting := lswitch;
%13
'Y':
resettty := lswitch;
'O':
openoutput := lswitch;
\
OTHERS:
IF lch %13 = 'B' (* 14.*) \
%24 IN ['B','E','F','I','L','P','R','U','Y','O'] (* 14.*) \ THEN
warning(169)
ELSE error(203)
END (*CASE LCH OF*)
END (*IF CH IN [+,-]+DIGITS*)
ELSE error(203);
IF eoln(source) THEN finishline
UNTIL ch <> ','
END (*OPTIONS*) ;
BEGIN (*SKIPCOMMENT*)
commentend := false; nextch; lcondcomp := false;
(* 3. TREAT '%'-'\' COMMENTS DIFFERENTLY.*)
IF onechar THEN
BEGIN
WHILE ch IN digits DO
BEGIN
IF ord(ch)-ord('0')=goodversion THEN
lcondcomp := true;
nextch;
END;
incondcomp := incondcomp OR lcondcomp;
IF NOT lcondcomp THEN
BEGIN
IF ch = '$' THEN options;
WHILE ch <> endchar DO
BEGIN
IF eoln (source) THEN
finishline;
nextch;
END;
nextch;
END;
END (*IF ONECHAR*)
ELSE
BEGIN
IF ch = '$' THEN options;
LOOP
WHILE ch = '*' DO
BEGIN
nextch;
commentend := ch = ')'
END
EXIT IF commentend; (* 3.*)
IF eoln(source) THEN finishline;
nextch
END (*LOOP*);
nextch
END;
END (*SKIPCOMMENT*);
%34
PROCEDURE skip_e_directory;
VAR
oldlptfile: boolean;
BEGIN (*SKIP_E_DIRECTORY*)
oldlptfile := lptfile;
lptfile := false;
WHILE NOT (ch = ';') DO
BEGIN
IF eoln(source) THEN
finishline;
nextch;
END;
nextch;
lptfile := oldlptfile;
END (*SKIP_E_DIRECTORY*);
\
(*]INSYMBOL*)
BEGIN (*INSYMBOL*)
111: (* 2. *)
WHILE ch = ' ' DO
BEGIN
IF eoln(source) THEN finishline;
nextch
END;
CASE ch OF
'%':
BEGIN
skipcomment (true,'\'); GOTO 111;
END;
%34
'"': (*SAIL WAY OF MAKING COMMENTS*)
BEGIN
IF incondcomp THEN
BEGIN
incondcomp := false;
nextch;
END
ELSE
skipcomment (true,'"');
GOTO 111;
END;
'#': (*PLEASE, GOD, FORGIVE ME!*)
BEGIN
WHILE ch = '#' DO
nextch;
IF eoln(source) THEN
finishline;
GOTO 111;
END;
\
'(':
BEGIN
nextch;
IF ch = '*' THEN
BEGIN
skipcomment (false,'*'); GOTO 111; (* 2.,3.*)
END
ELSE
BEGIN
sy := lparent; op := noop
END
END;
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y',
'Z':
BEGIN
k := 0 ; id := ' ';
REPEAT
IF k < alfalength THEN
BEGIN
k := k + 1; id[k] := ch
END ;
nextch
UNTIL NOT (ch IN identchars);
%34
IF first_symbol AND (id = 'COMMENT ') THEN
BEGIN
skip_e_directory;
GOTO 111;
END;
\
FOR i := frw[k] TO frw[k+1] - 1 DO
IF rw[i] = id THEN
BEGIN
sy := rsy[i];
op := rop[i];
IF (sy = initprocsy) AND NOT dp THEN error(363);
GOTO 222
END;
sy := ident; op := noop;
222:
END;
'0','1','2','3','4','5','6','7','8',
'9':
BEGIN
sy := intconst; op := noop;
id := ' ';
i := 0;
REPEAT
i := i + 1;
(* THE DIGITS OF AN "INTCONST" ARE STORED AS "IDENT" TOO. THIS ALLOWES
TO ENTER "LABELS" LIKE ALL OTHER IDENTIFIERS INTO THE BINARY-
(IDENTIFIER-)TREE VIA "ENTERID" AND LOCATE THEM VIA
"SEARCHID". SO "LABELS" ARE "KNOWN" AS CONSTANTS, TYPES OR
VARIABLES IN THE BLOCK THEY HAVE BEEN DECLARED IN.
IT IS ALSO POSSIBLE TO "EXIT" FROM A BLOCK, JUMPING TO A LABEL
WHICH IS DECLARED ON A LOWER LEVEL *)
IF i <= alfalength THEN id[i] := ch;
IF i <= maxdigits THEN digit[i] := ord(ch) - ord('0')
ELSE error(174) ;
nextch
UNTIL NOT (ch IN digits);
ival := 0;
IF ch = 'B' THEN
BEGIN
FOR k := 1 TO i DO
IF ival <= max8 THEN
BEGIN
IF digit[k] IN [8,9] THEN error(252);
ival := 8*ival + digit[k]
END
ELSE
IF (ival = test8) AND (digit[12] = 0) THEN ival := -maxint - 1
ELSE
BEGIN
error(204); ival := 0
END;
val.ival := ival;
nextch
END
ELSE
BEGIN
FOR k := 1 TO i DO
IF ival <= max10 THEN
IF (ival = max10) AND (digit[k] > 7) THEN
BEGIN
error(204); ival := 0
END
ELSE ival := 10*ival + digit[k]
ELSE
BEGIN
error(204); ival := 0
END;
scale := 0;
IF ch = '.' THEN
BEGIN
nextch;
IF ch = '.' THEN ch := ':'
ELSE
BEGIN
rval := ival; sy := realconst;
IF NOT (ch IN digits) THEN error(205)
ELSE
REPEAT
rval := 10.0*rval + (ord(ch) - ord('0'));
scale := scale - 1; nextch
UNTIL NOT (ch IN digits)
END
END;
IF ch = 'E' THEN
BEGIN
IF scale = 0 THEN
BEGIN
rval := ival; sy := realconst
END;
nextch;
sign := ch='-';
IF (ch='+') OR sign THEN nextch;
exponent := 0;
IF NOT (ch IN digits) THEN error(205)
ELSE
REPEAT
exponent := 10 * exponent + ord(ch) - ord('0');
nextch
UNTIL NOT (ch IN digits);
IF sign THEN scale := scale - exponent
ELSE scale := scale + exponent;
IF abs(round(scale/log_of_2 + expo(rval))) >= maxexp2 THEN
BEGIN
error(206); scale := 0
END
END;
IF scale <> 0 THEN
BEGIN
IF scale < 0 THEN
BEGIN
scale := abs(scale); fac := 0.1
END
ELSE fac := 10.0;
r := 1.0;
LOOP
IF odd(scale) THEN r := r * fac;
scale := scale DIV 2
EXIT IF scale = 0;
fac := sqr(fac)
END;
rval := rval * r (* RVAL := RVAL * 10 ** SCALE *)
END;
IF sy = intconst THEN val.ival := ival
ELSE
BEGIN
new(lvp,reel);
lvp↑.rval := rval; val.valp := lvp
END
END
END;
%12 '"': \
%34 '!': \
BEGIN
sy := intconst; op := noop; ival := 0;
nextch;
WHILE (ch IN hexadigits) AND (ival >= 0) DO
BEGIN
IF ival <= max16 THEN
IF ch IN digits THEN ival := 16*ival + (ord(ch) - ord('0'))
ELSE ival := 16*ival + (ord(ch) - 67B)
ELSE
IF (ival = test16) AND (ch = '0') THEN ival := -maxint - 1
ELSE
BEGIN
error(174); ival := 0
END;
nextch
END;
WHILE ch IN hexadigits DO nextch;
val.ival := ival
END;
'''':
BEGIN
lgth := 0; sy := stringconst; op := noop; stringtoolong := false;
REPEAT
REPEAT
nextch;
IF lgth <= strglgth THEN
BEGIN
lgth := lgth + 1;
IF lgth <= strglgth THEN string[lgth] := ch
END
ELSE stringtoolong := true
UNTIL eoln(source) OR (ch = '''');
IF stringtoolong THEN error(301);
IF ch <> '''' THEN error(351)
ELSE nextch
UNTIL ch <> '''';
lgth := lgth - 1;
IF lgth = 1 THEN val.ival := ord(string[1])
ELSE
BEGIN
new(lvp,strg:lgth);
WITH lvp↑ DO
BEGIN
slgth := lgth;
pack(string,1,sval,1,lgth)
END;
val.valp := lvp
END
END;
':':
BEGIN
op := noop; nextch;
IF ch = '=' THEN
BEGIN
sy := becomes; nextch
END
ELSE sy := colon
END;
'.':
BEGIN
op := noop; nextch;
IF ch = '.' THEN
BEGIN
sy := colon; nextch
END
ELSE sy := period
END;
'<','>':
BEGIN
sy := relop; op := sop[ch]; nextch;
IF (op=ltop) AND (ch='>') THEN
BEGIN
op := neop; nextch
END
ELSE
IF ch = '=' THEN
BEGIN
IF op = ltop THEN op := leop
ELSE op := geop;
nextch
END
END;
(* 8. ALLOW THE '\' AT END OF A CONDITIONALY COMPILED PART.*)
'\':
IF incondcomp THEN
BEGIN
incondcomp := false;
nextch;
GOTO 111;
END
ELSE
GOTO 333;
OTHERS:
BEGIN
333:
sy := ssy[ch]; op := sop[ch];
nextch
END
END (*CASE*);
first_symbol := false;
IF symcnt < 2 THEN (* 30.*)
symcnt := symcnt + 1;
END (*INSYMBOL*) ;
(*SEARCHSECTION, SEARCHID, SKIPIFERR, IFERRSKIP, ERRANDSKIP*)
PROCEDURE searchsection(fcp: ctp; VAR fcp1: ctp);
(*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
--> PROCEDURE PROCEDUREDECLARATION
--> PROCEDURE SELECTOR*)
LABEL
333;
BEGIN (*SEARCHSECTION*)
WHILE fcp <> NIL DO
WITH fcp↑ DO
BEGIN
IF name = id THEN GOTO 333;
IF name < id THEN fcp := rlink
ELSE fcp := llink
END;
333:
fcp1 := fcp
END (*SEARCHSECTION*) ;
PROCEDURE searchid(fidcls: setofids; VAR fcp: ctp);
LABEL
444;
VAR
lcp: ctp;
BEGIN (*SEARCHID*)
FOR disx := top DOWNTO 0 DO
BEGIN
lcp := display[disx].fname;
WHILE lcp <> NIL DO
WITH lcp↑ DO
IF name = id THEN
IF klass IN fidcls THEN GOTO 444
ELSE
BEGIN
IF search_error THEN error(401);
lcp := rlink
END
ELSE
IF name < id THEN lcp := rlink
ELSE lcp := llink
END;
(*SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
--> PROCEDURE SIMPLETYPE*)
IF search_error THEN
BEGIN
IF id[1] IN digits THEN error(215) (*UNDECLARED LABEL*)
ELSE error(253) (*UNDECLARED IDENTIFIER*);
(*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
FOR AN UNDECLARED ID OF APPROPRIATE CLASS
--> PROCEDURE ENTERUNDECL*)
IF types IN fidcls THEN lcp := utypptr
ELSE
IF vars IN fidcls THEN lcp := uvarptr
ELSE
IF field IN fidcls THEN lcp := ufldptr
ELSE
IF konst IN fidcls THEN lcp := ucstptr
ELSE
IF proc IN fidcls THEN lcp := uprcptr
ELSE lcp := ufctptr
END;
444:
fcp := lcp
END (*SEARCHID*) ;
PROCEDURE skipiferr(fsyinsys:setofsys; ferrnr:integer; fskipsys: setofsys);
VAR
i,oldchcnt,oldlinecnt : integer;
BEGIN (*SKIPIFERR*)
IF NOT (sy IN fsyinsys) THEN
BEGIN
error(ferrnr);
oldlinecnt := linecnt; oldchcnt := chcnt;
WHILE NOT (sy IN fskipsys + fsyinsys) DO
BEGIN
(*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*)
IF oldlinecnt <> linecnt THEN oldchcnt := 1;
FOR i := oldchcnt TO chcnt-1 DO
IF i <= chcntmax THEN errline [i] := '*';
oldchcnt := chcnt; oldlinecnt := linecnt; errorinline := true;
insymbol
END
END;
followerror := false
END (*SKIPIFERR*);
PROCEDURE iferrskip(ferrnr: integer; fsys: setofsys);
BEGIN (*IFERRSKIP*)
skipiferr(fsys,ferrnr,fsys)
END (*IFERRSKIP*);
PROCEDURE errandskip(ferrnr: integer; fsys: setofsys);
BEGIN (*ERRANDSKIP*)
skipiferr([ ],ferrnr,fsys)
END (*ERRANDSKIP*);
(* BLOCK[ TYPE CHECKING: CONSTANT, GETBOUNDS, STRING, COMPTYPES[CHECKSSTRING[ISMAGIC]] *)
PROCEDURE block(fprocp: ctp; fsys,leaveblocksys: setofsys);
TYPE
marker = ↑integer;
VAR
lsy: symbol; current_jump: 0..jump_max;
testpacked: boolean;
lcpar: addrrange;
heapmark, globmark: marker;
forward_procedures : ctp;
firstline,beginline: integer;
PROCEDURE constant(fsys: setofsys; VAR fsp: stp; VAR fvalu: valu);
VAR
lsp, lsp1: stp;
lcp: ctp;
sign: (none,pos,neg);
BEGIN (*CONSTANT*)
lsp := NIL; fvalu.ival := 0;
skipiferr(constbegsys,207,fsys);
IF sy IN constbegsys THEN
BEGIN
IF sy = stringconst THEN
BEGIN
IF lgth = 1 THEN lsp := asciiptr
ELSE
IF lgth = alfalength THEN lsp := alfaptr
ELSE
BEGIN
new(lsp,arrays); new(lsp1,subrange);
WITH lsp↑ DO
BEGIN
selfstp := NIL; aeltype := asciiptr; inxtype := lsp1;
size := (lgth+4) DIV 5; arraypf := true;
bitsize := bitmax
END;
WITH lsp1↑ DO
BEGIN
selfstp := NIL; size := 1; bitsize := bitmax;
vmin.ival := 1; vmax.ival := lgth; rangetype := intptr
END
END;
fvalu := val; insymbol
END
ELSE
BEGIN
sign := none;
IF (sy = addop) AND (op IN [plus,minus]) THEN
BEGIN
IF op = plus THEN sign := pos
ELSE sign := neg;
insymbol
END;
IF sy = ident THEN
BEGIN
searchid([konst],lcp);
WITH lcp↑ DO
BEGIN
lsp := idtype; fvalu := values
END;
IF sign <> none THEN
IF lsp = intptr THEN
BEGIN
IF sign = neg THEN fvalu.ival := -fvalu.ival
END
ELSE
IF lsp = realptr THEN
BEGIN
IF sign = neg THEN
fvalu.valp↑.rval := -fvalu.valp↑.rval
END
ELSE error(167);
insymbol
END
ELSE
IF sy = intconst THEN
BEGIN
IF sign = neg THEN val.ival := -val.ival;
lsp := intptr; fvalu := val; insymbol
END
ELSE
IF sy = realconst THEN
BEGIN
IF sign = neg THEN val.valp↑.rval := -val.valp↑.rval;
lsp := realptr; fvalu := val; insymbol
END
ELSE errandskip(168,fsys)
END;
iferrskip(166,fsys)
END;
fsp := lsp
END (*CONSTANT*) ;
PROCEDURE getbounds(fsp: stp; VAR fmin, fmax: integer); FORWARD;
FUNCTION string(fsp: stp) : boolean; FORWARD; (* 25.*)
FUNCTION comptypes(fsp1,fsp2: stp) : boolean;
(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
VAR
nxt1,nxt2: ctp; comp: boolean; lmin,lmax,i: integer;
ltestp1,ltestp2: testp;
lsstrp: sstrptr; (* 25.*)
(* 25. TO KEEP THE LENGTH OF PACKED ARRAYS OF CHAR, FOR STRING PROCEDURE CALLS.*)
FUNCTION checksstring(fsp: stp) : boolean;
VAR
lmin, lmax: integer;
ok: boolean;
FUNCTION ismagic (name: alfa; fkind: namekind; ffirst,flast: integer) : boolean;
VAR
index: integer;
BEGIN (*ISMAGIC*)
ismagic := false;
index := ffirst;
WHILE index <= flast DO
IF name = na[fkind, index] THEN
BEGIN
ismagic := true;
index := flast + 1;
END
ELSE
index := index + 1;
END (*ISMAGIC*);
BEGIN (*CHECKSSTRING*)
checksstring := false;
IF pctp↑.klass = proc THEN
ok := ismagic(pctp↑.name,declproc,14,17) (* PUTCHAR TO CONCAT *)
ELSE
ok := ismagic(pctp↑.name,declfunc,21,29);
(* LENGTH TO STRNE *)
IF ok THEN
IF string(fsp) THEN
BEGIN
IF fsp↑.arraypf THEN
BEGIN
checksstring := true;
getbounds(fsp↑.inxtype,lmin,lmax);
sstringlength↑.value[sstringlength↑.count] := lmax-lmin+1;
END
END
ELSE
IF comptypes (fsp,asciiptr) THEN
BEGIN
checksstring := true;
sstringlength↑.value[sstringlength↑.count] := 1;
END;
END (*CHECKSSTRING*);
(* 25.*)
BEGIN (*COMPTYPES*)
(* 25. COUNT THE SSTRINGS THAT ARE CHECKED *)
IF stringpack THEN
IF parsingparameters THEN
IF (fsp1 = sstringptr) OR (fsp2 = sstringptr) THEN
IF NOT recall THEN
BEGIN
recall := true;
IF sstringstart THEN
BEGIN
new(lsstrp);
WITH lsstrp↑ DO
BEGIN
next := sstringlength; count := 0;
value[1] := xtrastrglgth; value[2] := xtrastrglgth;
END;
sstringlength := lsstrp;
sstringstart := false;
END;
sstringlength↑.count := sstringlength↑.count + 1;
END;
(* 25.*)
IF fsp1 = fsp2 THEN comptypes := true
ELSE
IF (fsp1 <> NIL) AND (fsp2 <> NIL) THEN
IF fsp1↑.form = fsp2↑.form THEN
CASE fsp1↑.form OF
scalar:
comptypes := false;
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE*)
subrange:
comptypes := comptypes(fsp1↑.rangetype,fsp2↑.rangetype);
pointer:
BEGIN
comp := false; ltestp1 := globtestp; ltestp2 := globtestp;
WHILE ltestp1 <> NIL DO
WITH ltestp1↑ DO
BEGIN
IF (elt1 = fsp1↑.eltype) AND (elt2 = fsp2↑.eltype) THEN comp := true;
ltestp1 := lasttestp
END;
IF NOT comp THEN
BEGIN
new(ltestp1);
WITH ltestp1↑ DO
BEGIN
elt1 := fsp1↑.eltype;
elt2 := fsp2↑.eltype;
lasttestp := globtestp
END;
globtestp := ltestp1; comp := comptypes(fsp1↑.eltype,fsp2↑.eltype)
END;
comptypes := comp; globtestp := ltestp2
END;
power:
comptypes := comptypes(fsp1↑.elset,fsp2↑.elset);
arrays:
BEGIN
getbounds(fsp1↑.inxtype,lmin,lmax);
i := lmax-lmin;
getbounds(fsp2↑.inxtype,lmin,lmax);
comptypes := comptypes(fsp1↑.aeltype,fsp2↑.aeltype)
AND (fsp1↑.arraypf = fsp2↑.arraypf) AND ( i = lmax - lmin ) ;
END;
records:
BEGIN
nxt1 := fsp1↑.fstfld; nxt2 := fsp2↑.fstfld; comp := true;
WHILE (nxt1 <> NIL) AND (nxt2 <> NIL) DO
BEGIN
comp := comptypes(nxt1↑.idtype,nxt2↑.idtype) AND comp;
nxt1 := nxt1↑.next; nxt2 := nxt2↑.next
END;
comptypes := comp AND (nxt1 = NIL) AND (nxt2 = NIL)
AND (fsp1↑.recvar = NIL) AND (fsp2↑.recvar = NIL)
END;
(*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IF NO VARIANTS OCCUR*)
files:
comptypes := comptypes(fsp1↑.filtype,fsp2↑.filtype)
END (*CASE*)
ELSE (*FSP1↑.FORM <> FSP2↑.FORM*)
IF fsp1↑.form = subrange THEN comptypes := comptypes(fsp1↑.rangetype,fsp2)
ELSE
IF fsp2↑.form = subrange THEN comptypes := comptypes(fsp1,fsp2↑.rangetype)
ELSE
(* 25. ACCEPT PACKED ARRAYS OF CHAR AND CHAR AS SSTRINGS.*)
IF stringpack AND parsingparameters THEN
IF fsp1 = sstringptr THEN
comptypes := checksstring(fsp2)
ELSE
comptypes := false
ELSE
comptypes := false
ELSE comptypes := true
END (*COMPTYPES*) ;
PROCEDURE getbounds; (* (FSP: STP; VAR FMIN, FMAX: INTEGER) *)
(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
BEGIN (*GETBOUNDS*)
fmin := 0; fmax := 0;
IF fsp <> NIL THEN
IF fsp = intptr THEN
BEGIN (* TYPE INTEGER = MININT..MAXINT *)
fmin := -maxint - 1;
fmax := maxint
END
ELSE
IF (fsp↑.form <= subrange) AND NOT comptypes(realptr,fsp) THEN
WITH fsp↑ DO
IF form = subrange THEN
BEGIN
fmin := vmin.ival;
fmax := vmax.ival
END
ELSE
IF fsp = asciiptr THEN
BEGIN (* TYPE ASCII = NUL..DEL *)
fmin := ord(nul);
fmax := ord(del)
END
ELSE
IF fconst <> NIL THEN fmax := fconst↑.values.ival
ELSE fmax := 0
END (*GETBOUNDS*) ;
FUNCTION string (* (FSP: STP) : BOOLEAN *) ; (* RETURNS TRUE IF FSP DESCRIBES A PACKED ARRAY OF CHAR *)
BEGIN (*STRING*)
string := false;
IF fsp <> NIL THEN
IF fsp↑.form = arrays THEN string := comptypes(fsp↑.aeltype,asciiptr)
END (*STRING*) ;
(* TYPEDEFINITION (TYPE DEFINITION PARSER) *)
PROCEDURE typedefinition(fsys: setofsys; VAR fsp: stp; VAR fsize: addrrange;
VAR fbitsize: bitrange);
VAR
lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
lsize,displ: addrrange; i,lmin,lmax: integer;
packflag: boolean; lbitsize: bitrange;
lbtp: btp; bitcount:integer; bytes: bitrange;
FUNCTION log2(fval: integer): bitrange;
VAR
e: bitrange; h: integer;
BEGIN (*LOG2*)
e := 0; h := 1;
REPEAT
e := e + 1; h := h * 2
UNTIL fval <= h;
log2 := e
END (*LOG2*);
PROCEDURE simpletype(fsys: setofsys; VAR fsp: stp; VAR fsize: addrrange;
VAR fbitsize: bitrange);
VAR
lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
lcnt: integer; lvalu: valu; lbitsize: bitrange;
BEGIN (*SIMPLETYPE*)
fsize := 1;
skipiferr(simptypebegsys,208,fsys);
IF sy IN simptypebegsys THEN
BEGIN (* DECLARED SCALARS *)
IF sy = lparent THEN
BEGIN
ttop := top;
WHILE display[top].occur <> blck DO top := top - 1;
new(lsp,scalar,declared);
lcp1 := NIL; lcnt := 0;
REPEAT
insymbol;
IF sy = ident THEN
BEGIN
new(lcp,konst);
WITH lcp↑ DO
BEGIN
name := id; idtype := lsp; next := lcp1;
values.ival := lcnt
END;
enterid(lcp);
lcnt := lcnt + 1;
lcp1 := lcp; insymbol
END
ELSE error(209);
iferrskip(166,fsys + [comma,rparent])
UNTIL sy <> comma;
top := ttop;
WITH lsp↑ DO
BEGIN
selfstp := NIL; fconst := lcp1; size := 1; bitsize := log2(lcnt);
(*ADDITIONAL INFORMATION NEEDED TO STORE IDENTS OF DECLARED
SCALARS USED BY READ AND WRITE*)
vectorchain := 0; dimension := lcnt - 1; request := false;
nextscalar := declscalptr; declscalptr := lsp;
vectoraddr := 0; tlev := level
END;
IF sy = rparent THEN insymbol
ELSE error(152)
END (* SY = LPARENT *)
ELSE
BEGIN (* DEFINED CONSTANTS *)
IF sy = ident THEN
BEGIN
searchid([types,konst],lcp);
insymbol;
IF lcp↑.klass = konst THEN
BEGIN
new(lsp,subrange);
WITH lsp↑, lcp↑ DO
BEGIN
selfstp := NIL; rangetype := idtype;
IF string(rangetype) THEN
BEGIN
error(303); rangetype := NIL
END;
vmin := values; size := 1
END;
IF sy = colon THEN insymbol
ELSE error(151);
constant(fsys,lsp1,lvalu);
WITH lsp↑ DO
BEGIN
vmax := lvalu;
IF (vmin.ival < 0) OR (rangetype = realptr) THEN bitsize := bitmax
ELSE
IF vmax.ival = maxint THEN bitsize := bitmax
ELSE bitsize := log2(vmax.ival + 1);
IF NOT comptypes(rangetype,lsp1) THEN error(304)
END
END
ELSE
BEGIN
lsp := lcp↑.idtype;
IF lsp <> NIL THEN fsize := lsp↑.size
END
END (*SY = IDENT*)
ELSE (* SELF-DEFINING CONSTANTS *)
BEGIN
new(lsp,subrange);
constant(fsys + [colon],lsp1,lvalu);
IF string(lsp1) THEN
BEGIN
error(303); lsp1 := NIL
END;
WITH lsp↑ DO
BEGIN
rangetype := lsp1; vmin := lvalu; size := 1
END;
IF sy = colon THEN insymbol
ELSE error(151);
constant(fsys,lsp1,lvalu);
WITH lsp↑ DO
BEGIN
selfstp := NIL; vmax := lvalu;
IF (vmin.ival < 0) OR (rangetype = realptr) THEN bitsize := bitmax
ELSE
IF vmax.ival = maxint THEN bitsize := bitmax
ELSE bitsize := log2(vmax.ival + 1);
IF NOT comptypes(rangetype,lsp1) THEN error(304)
END
END;
IF lsp <> NIL THEN WITH lsp↑ DO
IF form = subrange THEN
IF rangetype <> NIL THEN
IF rangetype = realptr THEN
BEGIN
IF vmin.valp↑.rval > vmax.valp↑.rval THEN error(451)
END
ELSE
IF vmin.ival > vmax.ival THEN error(451)
END;
fsp := lsp;
IF lsp<>NIL THEN fbitsize := lsp↑.bitsize
ELSE fbitsize := 0;
iferrskip(166,fsys)
END
ELSE
BEGIN
fsp := NIL; fbitsize := 0
END
END (*SIMPLETYPE*) ;
PROCEDURE fieldlist(fsys: setofsys; VAR frecvar: stp; VAR ffirstfield: ctp);
LABEL
555;
VAR
lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4,tagsp: stp;
minsize,maxsize,lsize: addrrange; lvalu: valu;
lbitsize: bitrange;
lbtp: btp; minbitcount:integer;
lid : alfa ;
PROCEDURE recsection( VAR fcp: ctp; fsp: stp );
BEGIN (*RECSECTION*)
IF NOT packflag OR (lsize > 1) OR (lbitsize = 36) THEN
BEGIN
IF bitcount > 0 THEN
BEGIN
displ := displ + 1; bitcount := 0
END;
WITH fcp↑ DO
BEGIN
idtype := fsp; fldaddr := displ;
packf := notpack; fcp := next;
displ := displ + lsize
END
END
ELSE (*PACKED RECORDS*)
BEGIN
bitcount := bitcount + lbitsize;
IF bitcount>bitmax THEN
BEGIN
displ := displ + 1;
bitcount := lbitsize
END;
IF (lbitsize = 18) AND (bitcount IN [18,36]) THEN
BEGIN
WITH fcp↑ DO
BEGIN
idtype := fsp;
fldaddr := displ;
IF bitcount = 18 THEN packf := hwordl
ELSE packf := hwordr;
fcp := next
END
END
ELSE
WITH fcp↑, fldbyte DO
BEGIN
sbits := lbitsize;
pbits := bitmax - bitcount;
reladdr := displ;
dummybit := 0;
ibit := 0;
idtype := fsp;
packf := packk;
fcp := next
END
END
END (* RECSECTION *) ;
BEGIN (* FIELDLIST *)
nxt1 := NIL; lsp := NIL;
(* 13. ALLOW EXTRA SEMICOLONS AND NULL FIELDLISTS *)
WHILE sy = semicolon DO
insymbol;
skipiferr(fsys + [ident,casesy],452,fsys);
WHILE sy = ident DO
BEGIN
nxt := nxt1;
LOOP
IF sy = ident THEN
BEGIN
new(lcp,field);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; next := nxt
END;
nxt := lcp;
enterid(lcp);
insymbol
END
ELSE error(209);
skipiferr([comma,colon],166,fsys + [semicolon,casesy])
EXIT IF sy <> comma ;
insymbol
END;
IF sy = colon THEN insymbol
ELSE error(151);
typedefinition(fsys + [casesy,semicolon],lsp,lsize,lbitsize);
IF lsp <> NIL THEN
IF lsp↑.form = files THEN error(254);
(*ASSIGN MEMORY SPACE FOR THE FIELDS IN THIS CYCLE*)
WHILE nxt <> nxt1 DO
recsection(nxt,lsp);
nxt1 := lcp;
(* 13. ALLOW NULL ENTRIES.*)
WHILE sy = semicolon DO
BEGIN
insymbol;
skipiferr(fsys + [ident,casesy,semicolon],452,fsys);
END;
END (*WHILE*);
nxt := NIL;
WHILE nxt1 <> NIL DO
WITH nxt1↑ DO
BEGIN
lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp
END;
ffirstfield := nxt;
IF sy = casesy THEN
BEGIN
lcp:=NIL; (*POSSIBILITY OF NO TAGFIELD IDENTIFIER*)
insymbol;
IF sy = ident THEN
BEGIN
lid := id ;
insymbol ;
IF (sy<>colon) AND (sy<>ofsy) THEN
BEGIN
error(151) ;
errandskip(160,fsys + [lparent])
END
ELSE
BEGIN
IF sy = colon THEN
BEGIN
new(lsp,tagfwithid);
new(lcp,field) ;
WITH lcp↑ DO
BEGIN
name := lid ; idtype := NIL ; next := NIL
END ;
enterid(lcp) ;
insymbol ;
IF sy <> ident THEN
BEGIN
errandskip(209,fsys + [lparent]) ; GOTO 555
END
ELSE
BEGIN
lid := id ;
insymbol ;
IF sy <> ofsy THEN
BEGIN
errandskip(160,fsys + [lparent]) ; GOTO 555
END
END
END
ELSE new(lsp,tagfwithoutid) ;
WITH lsp↑ DO
BEGIN
size:= 0 ; selfstp := NIL ;
fstvar := NIL;
IF form=tagfwithid THEN tagfieldp:=NIL
ELSE tagfieldtype := NIL
END;
frecvar := lsp;
id := lid ;
searchid([types],lcp1) ;
tagsp := lcp1↑.idtype;
IF tagsp <> NIL THEN
IF (tagsp↑.form <= subrange) OR string(tagsp) THEN
BEGIN
IF comptypes(realptr,tagsp) THEN error(210)
ELSE
IF string(tagsp) THEN error(169);
WITH lsp↑ DO
BEGIN
bitsize := tagsp↑.bitsize;
IF form = tagfwithid THEN tagfieldp := lcp
ELSE tagfieldtype := tagsp
END;
IF lcp <> NIL THEN
BEGIN
lbitsize :=tagsp↑.bitsize;
lsize := tagsp↑.size;
recsection(lcp,tagsp); (*RESERVES SPACE FOR THE TAGFIELD *)
IF bitcount > 0 THEN lsp↑.size := displ + 1
ELSE lsp↑.size := displ
END
END
ELSE error(402);
insymbol
END
END
ELSE errandskip(209,fsys + [lparent]) ;
555:
lsp1 := NIL; minsize := displ; maxsize := displ; minbitcount:=bitcount;
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
LOOP
lsp2 := NIL;
LOOP
constant(fsys + [comma,colon,lparent],lsp3,lvalu);
IF NOT comptypes(tagsp,lsp3) THEN error(305);
new(lsp3,variant);
WITH lsp3↑ DO
BEGIN
nxtvar := lsp1; subvar := lsp2; varval := lvalu;
bitsize := lsp↑.bitsize; selfstp := NIL
END;
lsp1 := lsp3; lsp2 := lsp3
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN insymbol
ELSE error(151);
IF sy = lparent THEN insymbol
ELSE error(153);
fieldlist(fsys + [rparent,semicolon],lsp2,lcp);
IF bitcount > 0 THEN
BEGIN
displ := displ + 1 ; bitcount := 0
END ;
IF displ > maxsize THEN maxsize := displ;
WHILE lsp3 <> NIL DO
BEGIN
lsp4 := lsp3↑.subvar; lsp3↑.subvar := lsp2; lsp3↑.firstfield := lcp;
lsp3↑.size := displ ;
lsp3 := lsp4
END;
IF sy = rparent THEN
BEGIN
insymbol;
iferrskip(166,fsys + [semicolon])
END
ELSE error(152);
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
EXIT IF sy IN fsys;
displ := minsize;
bitcount := minbitcount;
END;
displ := maxsize;
lsp↑.fstvar := lsp1
END (*IF SY = CASESY*)
ELSE
IF lsp <> NIL THEN
IF lsp↑.form = arrays THEN frecvar := lsp
ELSE frecvar := NIL
END (*FIELDLIST*) ;
BEGIN (*TYPEDEFINITION*)
skipiferr(typebegsys,170,fsys);
IF sy IN typebegsys THEN
BEGIN
IF sy IN simptypebegsys THEN simpletype(fsys,fsp,fsize,fbitsize)
ELSE
IF sy = arrow THEN
BEGIN
new(lsp,pointer); fsp := lsp;
lbitsize := 18;
WITH lsp↑ DO
BEGIN
selfstp := NIL; eltype := NIL; size := 1; bitsize := lbitsize
END;
insymbol;
IF sy = ident THEN
BEGIN
search_error := false;
searchid([types],lcp);
search_error := true;
IF lcp = NIL THEN (*FORWARD REFERENCED TYPE ID*)
BEGIN
new(lcp,types);
WITH lcp↑ DO
BEGIN
name := id; idtype := lsp;
next := forward_pointer_type
END;
forward_pointer_type := lcp
END
ELSE
BEGIN
IF lcp↑.idtype <> NIL THEN
IF lcp↑.idtype↑.form = files THEN error(254)
ELSE lsp↑.eltype := lcp↑.idtype
END;
insymbol;
fbitsize:=18
END
ELSE error(209)
END
ELSE
BEGIN
IF sy = segmentsy THEN
BEGIN
error (169); (* 13.*)
insymbol;
skipiferr(typedels + [packedsy],170,fsys)
END;
IF sy = packedsy THEN
BEGIN
insymbol;
skipiferr(typedels,170,fsys);
packflag := true
END
ELSE packflag := false;
CASE sy OF
arraysy:
BEGIN
insymbol;
IF sy = lbrack THEN insymbol
ELSE error(154);
lsp1 := NIL;
LOOP
new(lsp,arrays);
WITH lsp↑ DO
BEGIN
aeltype := lsp1; inxtype := NIL; selfstp := NIL;
arraypf := packflag; size := 1
END;
lsp1 := lsp;
simpletype(fsys + [comma,rbrack,ofsy],lsp2,lsize,lbitsize);
IF lsp2 <> NIL THEN
IF lsp2↑.form <= subrange THEN
BEGIN
IF lsp2 = realptr THEN
BEGIN
error(210); lsp2 := NIL
END
ELSE
IF lsp2 = intptr THEN
BEGIN
error(306); lsp2 := NIL
END;
lsp↑.inxtype := lsp2
END
ELSE
BEGIN
error(403); lsp2 := NIL
END
EXIT IF sy <> comma;
insymbol
END;
IF sy = rbrack THEN insymbol
ELSE error(155);
IF sy = ofsy THEN insymbol
ELSE error(160);
typedefinition(fsys,lsp,lsize,lbitsize);
IF lsp <> NIL THEN
IF lsp↑.form = files THEN error(169) ;
REPEAT
WITH lsp1↑ DO
BEGIN
lsp2 := aeltype; aeltype := lsp;
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
i := lmax - lmin + 1;
IF arraypf AND (lbitsize<=18) THEN
BEGIN
bytes := bitmax DIV lbitsize;
WITH arraybps[lbitsize] DO
IF state = used THEN arraybpaddr := address
ELSE
BEGIN
new(lbtp);
WITH lbtp↑ DO
BEGIN
last := lastbtp; bitsize := lbitsize;
bytemax := bytes + 1 (*ONE MORE BYTEPOINTER USED FOR INCREMENT-OPERATIONS*) ;
arraysp := lsp1
END;
lastbtp := lbtp;
IF state = unused THEN
BEGIN
state := requested;
WITH abyte DO
BEGIN
sbits := lbitsize;
pbits := bitmax; dummybit := 0;
ibit := 0; ireg := reg1; reladdr := 0
END
END
END;
lsize := (i+bytes-1) DIV (bytes)
END
ELSE
BEGIN
lsize := lsize * i;
arraypf := false
END;
lbitsize := bitmax;
bitsize := lbitsize;
size := lsize
END
END;
lsp := lsp1; lsp1 := lsp2
UNTIL lsp1 = NIL
END;
recordsy:
BEGIN
insymbol;
oldtop := top;
IF top < displimit THEN
BEGIN
top := top + 1; display[top].fname := NIL ;
display[top].occur := crec ;
END
ELSE error(404);
displ := 0; bitcount := 0;
fieldlist(fsys-[semicolon] + [endsy],lsp1,lcp);
lbitsize := bitmax;
new(lsp,records);
WITH lsp↑ DO
BEGIN
selfstp := NIL;
fstfld := (*LCP;*) display[top].fname;
recvar := lsp1;
IF bitcount > 0 THEN size := displ + 1
ELSE size := displ;
bitsize := lbitsize; recordpf := packflag
END;
top := oldtop;
IF sy = endsy THEN insymbol
ELSE error(163)
END;
setsy:
BEGIN
insymbol;
IF sy = ofsy THEN insymbol
ELSE error(160);
simpletype(fsys,lsp1,lsize,lbitsize);
IF lsp1 <> NIL THEN
WITH lsp1↑ DO
CASE form OF
scalar:
IF scalkind = standard THEN error(268)
ELSE
IF fconst↑.values.ival > basemax THEN error(268);
subrange:
IF comptypes(rangetype,asciiptr) THEN
BEGIN
IF ((vmax.ival-offset) > basemax) OR ((vmin.ival-offset) < 0) THEN error(268)
END
ELSE
BEGIN
IF (rangetype = realptr) OR
((vmax.ival > basemax) OR (vmin.ival < 0)) THEN error(268)
END;
OTHERS:
BEGIN
error(461); lsp1 := NIL
END
END;
lbitsize := bitmax;
new(lsp,power);
WITH lsp↑ DO
BEGIN
selfstp := NIL; elset := lsp1; size:=2; bitsize := lbitsize
END
END;
filesy:
BEGIN
insymbol;
IF sy = ofsy THEN insymbol
ELSE error(160);
typedefinition(fsys,lsp1,lsize,lbitsize);
new(lsp,files);
lbitsize := bitmax;
WITH lsp↑ DO
BEGIN
selfstp := NIL;
filtype := lsp1; size := lsize+sizeoffileblock;
filepf := packflag; bitsize := lbitsize ;
(* REFER TO PROCEDURE "CODE_FOR_FILEBLOCKS"
IN "WRITE_MACHINE_CODE" *)
file_mode := binary_mode;
file_form := data_file;
IF comptypes(filtype,asciiptr) AND filepf THEN
BEGIN
file_mode := ascii_mode;
IF filtype <> NIL THEN
WITH filtype↑ DO
IF (form = subrange) AND
((vmin.ival >= ord(' ')) AND
(vmax.ival <= ord('_'))) THEN lsp↑.file_form := text_file
END;
IF filepf AND (file_mode = binary_mode) THEN filepf := false
END;
IF lsp1 <> NIL THEN
IF lsp1↑.form = files THEN
BEGIN
error(254); lsp↑.filtype := NIL
END
END
END (*CASE*);
fsp := lsp; fbitsize := lbitsize
END;
iferrskip(166,fsys)
END
ELSE fsp := NIL;
IF fsp = NIL THEN
BEGIN
fsize := 1;fbitsize := 0
END
ELSE fsize := fsp↑.size
END (*TYPEDEFINITION*) ;
(* PARSING OF DECLARATIONS: LABELDECLARATION, CONSTANTDECLARATION, TYPEDECLARATION, VARIABLEDECLARATION, proceduredeclaration[parameterlist[ffparlist]] *)
PROCEDURE labeldeclaration;
VAR
lcp: ctp;
BEGIN (*LABELDECLARATION*)
IF jumper < jump_max THEN jumper := jumper + 1
ELSE error(319);
current_jump := jumper;
jump_table[jumper] := 0;
LOOP
IF sy = intconst THEN
BEGIN
new(lcp,labels);
WITH lcp↑ DO
BEGIN
scope := level; name := id; idtype := NIL; next := last_label;
goto_chain := 0; label_address := 0; last_label := lcp;
jump_index := jumper; exit_jump := false;
IF val.ival > labmax THEN error(265)
END;
enterid(lcp);
insymbol
END
ELSE error(255);
iferrskip(166,fsys + [comma,semicolon])
EXIT IF sy <> comma;
insymbol
END;
IF sy = semicolon THEN insymbol
ELSE error(156)
END (*LABELDECLARATION*) ;
PROCEDURE constantdeclaration;
VAR
lcp: ctp; lsp: stp; lvalu: valu;
BEGIN (*CONSTANTDECLARATION*)
skipiferr([ident],209,fsys);
WHILE sy = ident DO
BEGIN
new(lcp,konst);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; next := NIL
END;
insymbol;
IF (sy = relop) AND (op = eqop) THEN insymbol
ELSE error(157);
constant(fsys + [semicolon],lsp,lvalu);
enterid(lcp);
lcp↑.idtype := lsp; lcp↑.values := lvalu;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE error(156)
END
END (*CONSTANTDECLARATION*) ;
PROCEDURE typedeclaration;
VAR
lcp,lcp1,lcp2: ctp; lsp: stp; lsize: addrrange;
lbitsize: bitrange;
BEGIN (*CONSTANTDECLARATION*)
skipiferr([ident],209,fsys);
WHILE sy = ident DO
BEGIN
new(lcp,types);
WITH lcp↑ DO
BEGIN
name := id; next := NIL
END;
insymbol;
IF (sy = relop) AND (op = eqop) THEN insymbol
ELSE error(157);
typedefinition(fsys + [semicolon],lsp,lsize,lbitsize);
enterid(lcp);
WITH lcp↑ DO
BEGIN
idtype := lsp;
(* LOOK FOR UNSATISFIED POINTER FORWARD REFERENCES;
THERE MAY BE MORE THAN ONE FOR ONE TYPE-DECLARATION *)
lcp1 := forward_pointer_type;
WHILE lcp1 <> NIL DO
BEGIN
IF lcp1↑.name = name THEN
BEGIN
IF idtype↑.form = files THEN
BEGIN
error(254);
lcp1↑.idtype↑.eltype := NIL
END
ELSE lcp1↑.idtype↑.eltype := idtype;
IF lcp1 <> forward_pointer_type THEN lcp2↑.next := lcp1↑.next
ELSE forward_pointer_type := lcp1↑.next
END
ELSE lcp2 := lcp1;
lcp1 := lcp1↑.next
END
END;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE error(156)
END;
WHILE forward_pointer_type <> NIL DO
BEGIN
error_with_text(405,forward_pointer_type↑.name);
forward_pointer_type := forward_pointer_type↑.next
END
END (*TYPEDECLARATION*) ;
PROCEDURE variabledeclaration;
VAR
lcp,nxt: ctp; lsp: stp; lsize: addrrange;
lbitsize: bitrange; lparmptr: ptp; found: boolean;
lfileptr: ftp;
BEGIN (*VARIABLEDECLARATION*)
nxt := NIL;
REPEAT
LOOP
IF sy = ident THEN
BEGIN
new(lcp,vars);
WITH lcp↑ DO
BEGIN
name := id; next := nxt;
idtype := NIL; vkind := actual; vlev := level
END;
enterid(lcp);
nxt := lcp;
insymbol
END
ELSE error(209);
skipiferr(fsys + [comma,colon] + typedels,166,[semicolon])
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN insymbol
ELSE error(151);
typedefinition(fsys + [semicolon] + typedels,lsp,lsize,lbitsize);
IF NOT testpacked AND (lsp <> NIL) THEN
BEGIN
IF lsp↑.form = arrays THEN testpacked := lsp↑.arraypf;
IF lsp↑.form = records THEN testpacked := lsp↑.recordpf
END;
WHILE nxt <> NIL DO
WITH nxt↑ DO
BEGIN
idtype := lsp;
%24 (* 20.*)
IF IDTYPE↑.FORM = FILES THEN
BEGIN
VADDR := FILELC;
FILELC := FILELC + LSIZE;
IF FILELC > MAXFILECODE THEN
ERROR (557);
END
ELSE
BEGIN
(* 20.*) \
vaddr := lc;
lc := lc + lsize ;
%24 END;
(* 20.*) \
IF lsp <> NIL THEN
IF lsp↑.form = files THEN
IF level > 1 THEN error(454)
ELSE
BEGIN
IF start_channel = 0 THEN channel := fileptr↑.fileident↑.channel
ELSE
BEGIN
channel := start_channel;
start_channel := 0
END;
IF channel < max_channel THEN channel := channel + 1
ELSE error(354);
new(lfileptr);
WITH lfileptr↑ DO
BEGIN
nextftp := fileptr ;
fileident := nxt
END ;
fileptr := lfileptr;
lparmptr := parmptr; found := false;
WHILE lparmptr <> NIL DO
WITH lparmptr↑ DO
BEGIN
IF fileid = name THEN
IF found THEN error(466)
ELSE
BEGIN
fileidptr := nxt; found := true
END;
lparmptr := nextptp
END
END (*ELSE*) ;
nxt := next
END;
IF sy = semicolon THEN
BEGIN
insymbol;
iferrskip(166,fsys + [ident])
END
ELSE error(156)
UNTIL NOT (sy IN typedels + [ident]);
WHILE forward_pointer_type <> NIL DO
BEGIN
error_with_text(405,forward_pointer_type↑.name);
forward_pointer_type := forward_pointer_type↑.next
END
END (*VARIABLEDECLARATION*) ;
PROCEDURE proceduredeclaration(procflag: boolean);
VAR
oldlev: 0..maxlevel; lcp,lcp1: ctp; lsp: stp;
forw: boolean; oldtop: disprange; lnxt: ctp;
oldcurrname: alfa; (* 27.*)
llc : addrrange;
lsys: setofsys;
PROCEDURE parameterlist(fsys:setofsys; VAR fip : ctp);
VAR
lip,lip1,lip2,lip3,lip4 : ctp; lsp : stp;
lkind : idkind; lpars:addrrange; funcdecl : boolean;
PROCEDURE ffparlist ( fsys : setofsys; VAR fip : ctp; VAR fparlc : addrrange);
VAR
lip,lip1,lip2,lip3 : ctp; lsp : stp;
lkind : idkind; lpars : addrrange; funcdecl : boolean;
BEGIN (*FFPARLIST*)
fip:=NIL;
skipiferr(fsys+[lparent],256,[]);
IF sy=lparent THEN
BEGIN
insymbol;
skipiferr([ident,varsy,proceduresy,functionsy],256,fsys+[rparent]);
IF sy IN [ident ,varsy,proceduresy,functionsy] THEN
LOOP
IF sy IN [proceduresy, functionsy] THEN
BEGIN
funcdecl:= sy=functionsy;
insymbol;
IF funcdecl THEN new(lip,func,declared,formal)
ELSE
new(lip,proc,declared,formal);
WITH lip↑ DO
BEGIN
idtype:=NIL; next:=NIL; pflev:=level;
pfaddr:=fparlc; fparlc:=fparlc+1;
lpars:=1+ord(funcdecl);
IF funcdecl THEN ffparlist(fsys+[rparent,colon,semicolon],lip3,lpars)
ELSE
ffparlist(fsys+[rparent,semicolon],lip3,lpars);
fparam:=lip3; parlistsize:=lpars;
END;
IF funcdecl THEN
IF sy=colon THEN
BEGIN
insymbol;
IF sy<>ident THEN error(209)
ELSE
BEGIN
searchid([types],lip2);
lsp:=lip2↑.idtype;
IF lsp<> NIL THEN
IF NOT(lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551);
lsp:=NIL
END;
lip↑.idtype:=lsp
END
END
ELSE error(151)
END (*SY IN [FUNCTIONSY,PROCEDURESY]*)
ELSE
BEGIN
IF sy=varsy THEN
BEGIN
insymbol;
lkind:=formal;
IF sy=colon THEN insymbol
ELSE error(151)
END
ELSE lkind:=actual;
IF sy=ident THEN
BEGIN
searchid([types],lip2);
insymbol;
lsp:=lip2↑.idtype;
IF lsp<>NIL THEN
IF lkind=actual THEN
IF lsp↑.form=files THEN
BEGIN
error(355); lsp:=NIL
END;
new(lip,vars);
WITH lip↑ DO
BEGIN
idtype:=lsp; next:=NIL; vkind:=lkind; vlev:=level;
vaddr:=fparlc;
IF lkind=formal THEN fparlc:=fparlc+1
ELSE
IF lsp<>NIL THEN fparlc:=fparlc+lsp↑.size;
END
END
ELSE
BEGIN
error(209); lip:=NIL
END
END;
IF lip<>NIL THEN
BEGIN
IF fip=NIL THEN fip:=lip
ELSE lip1↑.next:=lip;
lip1:=lip
END;
skipiferr([semicolon,ident,varsy,proceduresy,functionsy,rparent],256,fsys);
EXIT IF NOT(sy IN [semicolon,ident,varsy,proceduresy,functionsy]);
IF sy=semicolon THEN insymbol
ELSE error(156)
END (*LOOP*);
IF sy=rparent THEN insymbol
ELSE error(152);
skipiferr(fsys,166,[])
END
END (*FFPARLIST*);
BEGIN (*PARAMETERLIST*)
fip:=NIL; lip1:=NIL; lsp := NIL;
skipiferr(fsys+[lparent],256,[]);
IF sy=lparent THEN
BEGIN
IF forw THEN error(553);
insymbol;
skipiferr([proceduresy,functionsy,varsy,ident],256,fsys+[rparent]);
IF sy IN [proceduresy,functionsy,varsy,ident] THEN
LOOP
lip2:=NIL;
IF sy IN [proceduresy,functionsy] THEN
BEGIN
funcdecl:= sy=functionsy;
insymbol;
LOOP
IF sy=ident THEN
BEGIN
IF funcdecl THEN
new(lip,func,declared,formal)
ELSE
new(lip,proc,declared,formal);
WITH lip↑ DO
BEGIN
name:=id; next:=NIL; pflev:=level;idtype:=NIL;
pfaddr:=lc; lc:=lc+1; highest_register:=parregcmax
END;
enterid(lip);
insymbol;
IF fip=NIL THEN fip:=lip
ELSE lip1↑.next:=lip;
lip1:=lip;
IF lip2=NIL THEN lip2:=lip;
END
ELSE errandskip(209,fsys+[lparent,colon,comma,ident,semicolon,rparent]);
EXIT IF NOT (sy IN [comma,ident]);
IF sy=comma THEN insymbol
ELSE error(158)
END (*LOOP*);
IF funcdecl THEN
BEGIN
lpars:=2;
ffparlist(fsys+[colon,semicolon,rparent],lip3,lpars);
lsp:=NIL;
IF sy=colon THEN
BEGIN
insymbol;
IF sy=ident THEN
BEGIN
searchid([types],lip4);
lsp:=lip4↑.idtype;
IF lsp<>NIL THEN
IF NOT(lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551); lsp:=NIL
END;
insymbol
END
ELSE errandskip(209,fsys+[colon,comma,ident])
END
ELSE error(151);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
idtype:=lsp;
fparam:=lip3; parlistsize:=lpars;
lip2:=next
END
END
ELSE
BEGIN
lpars:=1;
ffparlist(fsys+[semicolon,rparent],lip3,lpars);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
fparam:=lip3;
parlistsize:=lpars;
lip2:=next
END
END
END (*SY IN [PROCEDURESY,FUNCTIONSY]*)
ELSE
BEGIN
IF sy=varsy THEN
BEGIN
lkind:=formal; insymbol
END
ELSE lkind:=actual;
LOOP
IF sy=ident THEN
BEGIN
new(lip,vars);
WITH lip↑ DO
BEGIN
name:=id; next:=NIL; vkind:=lkind; vlev:=level;
END;
enterid(lip);
insymbol;
IF fip=NIL THEN fip:=lip
ELSE lip1↑.next:=lip;
lip1:=lip;
IF lip2=NIL THEN lip2:=lip
END
ELSE errandskip(209,fsys+[colon,comma,ident]);
EXIT IF NOT(sy IN [comma,ident]);
IF sy=comma THEN insymbol
ELSE error(158)
END (*LOOP*);
IF sy=colon THEN
BEGIN
insymbol;
IF sy=ident THEN
BEGIN
searchid([types],lip3);
insymbol;
lsp:=lip3↑.idtype;
IF lsp<>NIL THEN
IF (lkind=actual) AND(lsp↑.form=files) THEN
BEGIN
error(355); lsp:=NIL
END
END
ELSE
error(209)
END
ELSE error(151);
WHILE lip2<>NIL DO WITH lip2↑ DO
BEGIN
vaddr:=lc;
IF lsp<>NIL THEN
IF vkind=formal THEN lc:=lc+1
ELSE lc:=lc+lsp↑.size;
idtype:=lsp;
lip2:=next
END;
END (*SY<>FUNCTIONSY*);
skipiferr([rparent,semicolon],256,[proceduresy,functionsy,ident,varsy]+fsys)
EXIT IF NOT(sy IN [semicolon,proceduresy,functionsy,varsy,ident]);
IF sy=semicolon THEN insymbol
ELSE error(156)
END (*LOOP*);
IF sy=rparent THEN insymbol
ELSE error(152);
skipiferr(fsys,166,[])
END (*SY=LPARENT*)
END (*PARAMETERLIST*);
BEGIN (*PROCEDUREDECLARATION*)
IF genprocfile THEN (* 27.*)
headline := linecnt;
oldcurrname := currname;
fsys:=fsys-[initprocsy];
llc := lc;
IF procflag THEN lc := 1
ELSE lc := 2;
IF sy = ident THEN
BEGIN
currname := id; (* 27.*)
searchsection(display[top].fname,lcp); (*DECIDE WHETHER DECLARED FORWARD*)
IF lcp <> NIL THEN (* IT SHOULD BE FORWARD *)
WITH lcp↑ DO
BEGIN
IF klass = proc THEN
IF pfkind=actual THEN forw:=forwdecl AND procflag
ELSE forw:=false
ELSE
IF klass = func THEN
IF pfkind=actual THEN forw:=forwdecl AND NOT procflag
ELSE forw:=false
ELSE forw := false;
IF NOT forw THEN error(558)
END
ELSE forw := false;
IF NOT forw THEN
BEGIN
IF procflag THEN new(lcp,proc,declared,actual)
ELSE new(lcp,func,declared,actual);
WITH lcp↑ DO
BEGIN
name := id; idtype := NIL; testfwdptr := NIL; highest_register := parregcmax;
forwdecl := false; externdecl := false; language := pascalsy; parlistsize:=0;
pflev := level; pfaddr := 0; FOR i := 0 TO maxlevel DO linkchain[i] := 0
END;
enterid(lcp)
END
ELSE lc:=lcp↑.parlistsize;
insymbol
END
ELSE (* SY <> IDENT *)
BEGIN
error(209);
IF procflag THEN lcp := uprcptr
ELSE lcp := ufctptr
END;
oldlev := level; oldtop := top;
IF level < maxlevel THEN level := level + 1
ELSE error(453);
IF top < displimit THEN
BEGIN
top := top + 1;
WITH display[top] DO
BEGIN
fname := NIL; occur := blck;
IF debug THEN
BEGIN
new(lcp1); lcp1↑ := uprcptr↑;
lcp1↑.next := lcp;
enterid(lcp1);
IF forw AND (lcp↑.next <> NIL) THEN
BEGIN
lcp1↑.llink := lcp↑.next; lcp1↑.rlink := lcp↑.next;
lcp↑.next↑.selfctp := NIL
END
END
ELSE (* NOT DEBUG *)
IF forw THEN fname := lcp↑.next
END (*WITH DISPLAY[TOP]*)
END
ELSE (* TOP >= DISPLIMIT *)
error(404);
IF procflag THEN
BEGIN
parameterlist([semicolon],lcp1);
IF NOT forw THEN WITH lcp↑ DO
BEGIN
next:=lcp1; parlistsize:=lc
END
END
ELSE (* NOT PROCFLAG *)
BEGIN
parameterlist([semicolon,colon],lcp1);
IF NOT forw THEN WITH lcp↑ DO
BEGIN
next := lcp1; parlistsize:=lc
END;
IF sy = colon THEN
BEGIN
insymbol;
IF sy = ident THEN
BEGIN
IF forw THEN error(552);
searchid([types],lcp1);
lsp := lcp1↑.idtype;
lcp↑.idtype := lsp;
IF lsp <> NIL THEN
IF NOT (lsp↑.form IN [scalar,subrange,pointer]) THEN
BEGIN
error(551); lcp↑.idtype := NIL
END;
insymbol
END
ELSE errandskip(209,fsys + [semicolon])
END
ELSE
IF NOT forw THEN error(455)
END;
IF sy = semicolon THEN insymbol
ELSE error(156);
IF sy = forwardsy THEN
BEGIN
IF forw THEN error(257)
ELSE
WITH lcp↑ DO
BEGIN
testfwdptr := forward_procedures; forward_procedures := lcp; forwdecl := true;
IF next <> NIL THEN next↑.selfctp := uvarptr
END;
insymbol;
IF sy = semicolon THEN insymbol
ELSE error(156);
iferrskip(166,fsys)
END (* SY = FORWARDSY *)
ELSE (* SY <> FORWARDSY *)
WITH lcp↑ DO
BEGIN
IF sy IN (languagesys + [externsy]) THEN
BEGIN
%24 ERROR(169); (*17.*) \
IF forw THEN error(257)
ELSE externdecl := true;
%13
IF NOT external THEN
BEGIN \
ttyread := ttyread OR resettty;
outputwrite := openoutput OR outputwrite; (* 13. OPEN OUTPUT ONLY IF NEEDED.*)
%13 (* 17.*) END;
\
IF level <> 2 THEN error(464);
IF sy IN languagesys THEN language := sy;
insymbol;
%13 (* 17.*)
IF (library_index = 0) OR (NOT library[language].chained) THEN
BEGIN
library_index:= library_index+1;
library_order[library_index]:= language;
library[language].chained:= true
END;
(* 17.*) \
pflev := 1; pfchain := externpfptr; externpfptr := lcp;
IF sy = semicolon THEN insymbol
ELSE error(156);
iferrskip(166,fsys)
END (* SY = EXTERNSY *)
ELSE (* (SY <> EXTERNSY) AND (SY <> FORWARDSY) *)
BEGIN
pfchain := localpfptr;
localpfptr := lcp;
forwdecl := false;
activated := true;
block(lcp,fsys,[beginsy,functionsy,proceduresy,period,semicolon]);
activated := false;
IF sy = semicolon THEN
BEGIN
lsys := [proceduresy,functionsy,beginsy];
%24 IF INITGLOBALS THEN
BEGIN
LSYS := LSYS + [INITPROCSY];
DP := TRUE;
END; \
insymbol;
%24 DP := FALSE; \
skipiferr(lsys,166,fsys)
END
ELSE error(156)
END (* SY <> EXTERNSY *)
END (* SY <> FORWARDSY *) ;
level := oldlev; top := oldtop; lc := llc;
currname := oldcurrname; (* 27.*)
END (*PROCEDUREDECLARATION*) ;
(* BODY[GENERATE_WORD,INSERT_ADDRESS,INCREMENT_REGC,DEPOSIT_CONSTANT,MACRO..,PUT_PAGENUMBER,PUT_LINENUMBER,SUPPORT,ALFACONSTANT,ADDNEWCOUNTER*)
PROCEDURE body(fsys: setofsys);
CONST
(* FILOPN = 3B; FILBTH = 20B; (* NOT USED.*)
fileof = 1B; fileol = 2B; filsta = 11B; fildev = 12B;
filbhp = 13B; filnam = 14B; fillnr = 23B; filcmp = 25B;
VAR
last_file: ctp;
reg2_saved: boolean;
reg2_location: addrrange;
PROCEDURE generate_word(frelbyte: relbyte; flefth: addrrange; frighth: addrrange);
BEGIN (*GENERATE_WORD*)
cix := cix + 1;
IF cix > code_size THEN
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN error_with_text(356,'MAIN ')
ELSE error_with_text(356,fprocp↑.name)
END;
cix := 0
END;
WITH code_array↑.halfword[cix] DO
BEGIN
lefthalf := flefth;
righthalf := frighth
END;
code_reference↑[cix] := noinstr; code_relocation↑[cix] := frelbyte;
ic := ic + 1
END (*GENERATE_WORD*) ;
PROCEDURE insert_address(frelbyte: relbyte; fcix:coderange; fic:addrrange);
BEGIN (*INSERT_ADDRESS*)
code_array↑.instruction[fcix].address := fic;
code_relocation↑[fcix] := frelbyte
END (*INSERT_ADDRESS*);
PROCEDURE increment_regc;
BEGIN (*INCREMENT_REGC*)
regc := regc + 1 ;
IF regc > regcmax THEN
BEGIN
error(310) ; regc := regin
END
END (*INCREMENT_REGC*);
PROCEDURE deposit_constant(konsttyp:cstclass; fattr:attr);
VAR
ii:integer;
lksp,llksp: ksp;
lcsp: csp;
lref: coderefs;
newconstant,existant:boolean;
lcix: coderange;
BEGIN (*DEPOSIT_CONSTANT*)
newconstant:=true; lksp := firstkonst; (* CHECK WHETEHER THE CONSTANT EXISTS ALREADY *)
WHILE (lksp <> NIL) AND newconstant DO
WITH lksp↑,constptr↑ DO
BEGIN
IF cclass = konsttyp THEN
CASE konsttyp OF
reel:
newconstant := rval <> fattr.cval.valp↑.rval;
int:
newconstant := intval <> fattr.cval.ival;
pset:
newconstant := pval <> fattr.cval.valp↑.pval;
bptr:
newconstant := byte <> fattr.cval.byte;
strd,
strg:
IF fattr.cval.valp↑.slgth = slgth THEN
BEGIN
existant := true;
ii := 1;
REPEAT
IF fattr.cval.valp↑.sval[ii] <> sval[ii] THEN existant := false;
ii:=ii+1
UNTIL (ii>slgth) OR NOT existant;
IF existant THEN newconstant := false
END
END (*CASE*);
llksp := lksp; lksp := nextkonst
END (*WHILE*);
IF konsttyp = bptr THEN lref := pointref
ELSE lref := constref;
IF NOT newconstant (* IF IT DOES NOT EXIST YET, CREATE IT *) THEN
WITH llksp↑ DO
BEGIN
insert_address(right,cix,addr); code_reference↑[cix]:= lref;
IF konsttyp IN [pset,strd] THEN
BEGIN
insert_address(right,cix-1,addr-1); code_reference↑[cix-1]:= lref
END;
addr:= ic-1
END
ELSE
BEGIN
IF konsttyp = int THEN
BEGIN
new(lcsp,int); lcsp↑.intval := fattr.cval.ival
END
ELSE
IF konsttyp = bptr THEN
BEGIN
new(lcsp,bptr); lcsp↑.byte := fattr.cval.byte
END
ELSE lcsp := fattr.cval.valp;
code_reference↑[cix] := lref;
IF konsttyp IN [pset,strd] THEN code_reference↑[cix-1] := lref;
new(lksp);
WITH lksp↑ DO
BEGIN
addr := ic-1; double_chain := konsttyp IN [pset,strd];
constptr := lcsp; nextkonst := NIL
END;
IF firstkonst = NIL THEN firstkonst := lksp
ELSE llksp↑.nextkonst := lksp
END
END (*DEPOSIT_CONSTANT*);
PROCEDURE macro(frelbyte : relbyte;
finstr : instrange;
fac : acrange;
findbit : ibrange;
finxreg : acrange;
faddress : addrrange);
BEGIN (*MACRO*)
%13
IF NOT initglobals THEN (* 24.*) \
BEGIN
cix := cix + 1;
IF cix > code_size THEN
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN error_with_text(356,'MAIN ')
ELSE error_with_text(356, fprocp↑.name)
END;
cix := 0
END;
WITH code_array↑.instruction[cix] DO
BEGIN
instr :=finstr;
ac :=fac;
indbit :=findbit;
inxreg :=finxreg;
address :=faddress;
code_reference↑[cix]:= noref; code_relocation↑[cix] := frelbyte
END;
ic := ic + 1
END
%13
ELSE error(507) (* 24.*) \
END (*MACRO*);
PROCEDURE macro5(frelbyte: relbyte; finstr : instrange; fac,finxreg : acrange; faddress : addrrange);
BEGIN
macro(frelbyte,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro4(finstr: instrange;fac, finxreg: acrange;faddress: addrrange);
BEGIN
macro(no,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro3(finstr : instrange; fac:acrange; faddress: addrrange);
BEGIN
macro(no,finstr,fac,0,0,faddress)
END;
PROCEDURE macro4r(finstr : instrange; fac,finxreg : acrange; faddress : addrrange);
BEGIN
macro(right,finstr,fac,0,finxreg,faddress)
END;
PROCEDURE macro3r(finstr : instrange; fac:acrange; faddress: addrrange);
BEGIN
macro(right,finstr,fac,0,0,faddress)
END;
PROCEDURE macro2(finstr: instrange; fac: acrange);
BEGIN
macro(no,finstr,fac,0,0,0)
END;
PROCEDURE put_pagenumber;
VAR
lrelbyte: relbyte;
BEGIN (*PUT_PAGENUMBER*)
lrelbyte := right;
WITH pager DO
BEGIN
lastpager := ic;
WITH word1 DO
BEGIN
IF (address = 0) OR (address = 377777B) THEN lrelbyte := no;
macro5(lrelbyte,304B(*CAIA*),ac,inxreg,address)
END;
IF (rhalf = 0) OR (rhalf = 377777B) THEN generate_word(no,lhalf,rhalf)
ELSE generate_word(right,lhalf,rhalf);
lastpage := pagecnt
END
END (*PUT_PAGENUMBER*);
PROCEDURE put_linenumber;
VAR
lrelbyte: relbyte;
BEGIN (*PUT_LINENUMBER*)
lrelbyte := right;
IF pagecnt <> lastpage THEN put_pagenumber;
IF linecnt <> lastline THEN (*BREAKPOINT*)
BEGIN
IF hassoslines THEN
BEGIN
linecnt := 0;
FOR i := 1 TO 5 DO linecnt := 10*linecnt + ord(linenr[i]) - ord('0')
END;
linediff := linecnt - lastline;
IF (laststop = 0) OR (laststop = 377777B) THEN lrelbyte := no;
IF linediff > 255 THEN
BEGIN
macro5(lrelbyte,334B(*SKIPA*),0,0,laststop);
laststop := ic-1;
macro3(320B(*JUMP*),0,lastline)
END
ELSE
BEGIN
macro5(lrelbyte,320B(*JUMP*),linediff MOD 16,linediff DIV 16,laststop); (*NOOP*)
laststop := ic - 1
END;
lastline := linecnt
END
END (*PUT_LINENUMBER*);
PROCEDURE support(fsupport: supports);
BEGIN (*SUPPORT*)
IF fsupport = fortranreset THEN macro3r(265B(*JSP*),basis,runtime_support.link[fortranreset])
ELSE
IF fsupport = exitprogram THEN macro3r(254B(*JRST*),0,runtime_support.link[exitprogram])
ELSE macro3r(260B(*PUSHJ*),topp,runtime_support.link[fsupport]);
code_reference↑[cix]:= externref;
%13 runtime_support.link[fsupport]:= ic-1 (* 19.*) \
END (*SUPPORT*);
PROCEDURE alfaconstant( fstring: alfa);
VAR
lcsp: csp;
BEGIN (*ALFACONSTANT*)
new(lcsp,strg);
WITH lcsp↑ DO
BEGIN
slgth := 10; FOR i := 1 TO 10 DO sval[i] := fstring[i]
END;
WITH gattr DO
BEGIN
typtr := alfaptr;
kind := cst; cval.valp := lcsp
END
END (*ALFACONSTANT*);
(*CLOSEFILES, ENTERBODY, LEAVEBODY*)
PROCEDURE close_files;
VAR
lfileptr: ftp;
BEGIN (*CLOSE_FILES*)
lfileptr := fileptr;
WHILE lfileptr <> NIL DO
WITH lfileptr↑, fileident↑ DO
BEGIN
%24
IF NAME <> 'TTYOUTPUT ' THEN
BEGIN (* 21.*) \
macro3r(551B(*HRRZI*),regin+1,vaddr);
support(closefile);
%24 END;
(* 21.*) \
lfileptr := nextftp
END;
%24 (* 21. CALL TO TIMEREPORT.*)
MACRO3R(551B(*HRRZI*),REGIN+1,STDFILEPTR[4]↑.VADDR);
ALFACONSTANT(PROGRAMNAME);
GATTR.CVAL.VALP↑.CCLASS := STRD;
MACRO2(200B(*MOVE*),REGIN+3);
MACRO2(200B(*MOVE*),REGIN+2);
DEPOSIT_CONSTANT (STRD,GATTR);
SUPPORT(SHOWRUNTIME);
(* 21.*) \
END (*CLOSE_FILES*);
PROCEDURE enterbody;
VAR
i: integer; lcp : ctp;
lbtp: btp;
BEGIN (*ENTERBODY*)
lbtp := lastbtp;
WHILE lbtp <> NIL DO
BEGIN
WITH lbtp↑, arraybps[bitsize] DO
IF state = requested THEN
BEGIN
arraysp↑.arraybpaddr := ic;
address := ic; state := calculated;
ic := ic + bytemax
END
ELSE arraysp↑.arraybpaddr := address;
lbtp := lbtp↑.last
END;
IF fprocp <> NIL THEN
BEGIN
generate_word(no,0,377777B); idtree := cix; (*IF DEBUG, INSERT TREE POINTER HERE*)
WITH fprocp↑ DO
IF pflev > 1 THEN FOR i := maxlevel DOWNTO pflev+1 DO
macro4(540B(*HRR*),basis,basis,-1);
pfstart := ic;
IF fprocp↑.pflev = 1 THEN macro4(512B(*HLLZM*),basis,topp,-1)
ELSE macro4(202B(*MOVEM*),basis,topp,-1);
macro3(507B(*HRLS*),basis,topp);
macro4(307B(*CAIG*),newreg,topp,0); stacksize1 := cix;
support(stackoverflow);
macro4(541B(*HRRI*),topp,topp,0); stacksize2 := cix;
IF testpacked THEN
IF lc-lcpar <= 4 THEN FOR i := lcpar TO lc-1 DO macro4(402B(*SETZM*),0,basis,i)
ELSE
BEGIN
macro4(551B(*HRRZI*),reg1,basis,lcpar);
macro3(505B(*HRLI*),reg1,lcpar-lc);
macro4(402B(*SETZM*),0,reg1,0);
macro3r(253B(*AOBJN*),reg1,ic-1)
END;
regc := regin+1;
lcp := fprocp↑.next;
WHILE lcp <> NIL DO
WITH lcp↑ DO
BEGIN
IF klass <> vars THEN
BEGIN
IF regc <= fprocp↑.highest_register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,pfaddr);
increment_regc
END
END
ELSE
IF idtype <> NIL THEN
IF (vkind=formal) OR (idtype↑.size=1) THEN (*COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS*)
BEGIN
IF regc <= fprocp↑.highest_register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,vaddr); regc := regc + 1
END
END
ELSE
IF idtype↑.size=2 THEN
BEGIN
IF regc <= fprocp↑.highest_register THEN
BEGIN
macro4(202B(*MOVEM*),regc,basis,vaddr);
IF regc<fprocp↑.highest_register THEN macro4(202B(*MOVEM*),regc+1,basis,vaddr+1)
END;
regc:=regc+2
END
ELSE
BEGIN
IF regc <= fprocp↑.highest_register THEN (*COPY MULTIPLE VALUES INTO LOCAL CELLS*)
BEGIN
macro3(514B(*HRLZ*),reg1,regc); regc := regc + 1
END
ELSE macro4(514B(*HRLZ*),reg1,basis,vaddr);
macro4(541B(*HRRI*),reg1,basis,vaddr);
macro4(251B(*BLT*),reg1,basis,vaddr+idtype↑.size-1)
END;
lcp := lcp↑.next
END
END
ELSE (* FPROCP = NIL *)
main_start := ic;
IF (current_jump <> 0) %13 AND (NOT external OR (level > 1)) \ (* 14.*) THEN
BEGIN
jump_table[current_jump] := ic;
macro2(202B(*MOVEM*),basis); code_reference↑[cix] := saveref;
macro2(202B(*MOVEM*),topp); code_reference↑[cix] := saveref
END
END (*ENTERBODY*);
PROCEDURE addnewcounter; FORWARD;
PROCEDURE leavebody;
VAR
lcp: ctp; i: integer;
lksp: ksp ; lparmptr: ptp;
ldeclscalptr: stp;
icchange: PACKED RECORD
CASE boolean OF
false:(icval: addrrange);
true :(iccsp: csp)
END;
%13 (* 28.*)
lpcreffile,lpcrefdevice: alfa;
(* 28.*) \
%24 LADDRESS: ADDRRANGE;
COUNTTOP,INDEX: 1..101;
LCNTP: CNTP; \
BEGIN (*LEAVEBODY*)
IF debug THEN put_linenumber;
IF fprocp <> NIL THEN (* IF LEAVING THE BODY OF A PROC/FUNC*)
BEGIN
IF entercount THEN
BEGIN (* 28.*)
addnewcounter; entercount := false;
END;
macro4(541B(*HRRI*),topp,basis,0);
macro4(547B(*HLRS*),basis,topp,-1);
macro3(263B(*POPJ*),topp,0)
END
ELSE (* FPROCP = NIL <=> LEAVING MAIN BODY.*)
BEGIN
%13 (* 14.*)
IF NOT external THEN
(* 14.*) \
BEGIN
close_files;
IF counting THEN (* 28. CALL THE RUNTIME THAT DUMPS THEM*)
BEGIN
FOR i := 1 TO 6 DO
kntname[i] := source_file[i];
kntname[7] := 'K';
kntname[8] := 'N';
kntname[9] := 'T';
alfaconstant(kntname);
gattr.cval.valp↑.cclass := strd;
macro2(200B(*MOVE*),regin+2);
macro2(200B(*MOVE*),regin+1);
deposit_constant(strd,gattr);
endofcounts := lcmain - 2;
macro3r(551B(*HRRZI*),regin+3,startofcounts);
macro3r(551B(*HRRZI*),regin+4,endofcounts);
support(dumpcounts);
%13
FOR i := 1 TO 9 DO
BEGIN
lpcreffile[i] := pcreffile[i];
IF i <= 6 THEN
lpcrefdevice[i] := pcrefdevice[i]
ELSE
lpcrefdevice[i] := ' ';
END;
lpcreffile[10] := ' ';
lpcrefdevice[10] := ' ';
\
%234
END;
IF cross_reference THEN (* 21.*)
BEGIN
\
%24
ALFACONSTANT(PCREFFILE);
(* 21.*) \
%13 alfaconstant(lpcreffile); \
macro2(551B(*HRRZI*),regin+1);
deposit_constant(strg,gattr);
%24 ALFACONSTANT(PCREFDEVICE); \
%13 alfaconstant(lpcrefdevice); \
macro2(551B(*HRRZI*),regin+2);
deposit_constant(strg,gattr);
macro3r(551B(*HRRZI*),regin+3,pcrefppn);
macro3r(551B(*HRRZI*),regin+4,pcrefcore);
support(runprogram);
END;
%13 (* 14.*)
IF library[fortransy].called AND fortran_enviroment THEN
BEGIN (* FORTRAN-STYLE I/O *)
macro3r(551B(*HRRZI*),regin + 1,stdfileptr[4]↑.vaddr);
support(putbuffer);
macro3(551B(*HRRZI*),basis,ic+3);
support(fortranexit);
generate_word(no,0,0);
generate_word(no,0,0)
END
ELSE
(* 14.*) \
support(exitprogram);
start_address := ic;
macro3(255B(*JFCL*),0,runcore*1024); (* START-UP CODE: REPORT LOWCORE SIZE,*)
macro3(554B(*HLRZ*),basis,jbsa); (* SET THE STACK FRAME *)
macro4(505B(*HRLI*),basis,basis,0);
macro4(541B(*HRRI*),topp,basis,0); (* AND THE STACK POINTER *)
stacksize1 := cix; stacksize2 := cix;
macro3r(550B(*HRRZ*),reg1,start_address); (* CHECK FOR MEMORY SPACE CONFLICTS *)
macro3(317B(*CAMG*),reg1,jbrel);
macro3r(254B(*JRST*),0,ic+3);
macro3(047B,reg1,11B(*CORE-UUO*));
support(nocoreavailable);
macro3(200B(*MOVE*),newreg,jbrel);
macro4(307B(*CAIG*),newreg,topp,40B);
support(stackoverflow);
macro3(506B(*HRLM*),newreg,jbsa);
macro3(275B(*SUBI*),newreg,1);
macro3(505B(*HRLI*),topp,400000B);
macro3(047B,reg0,0(*RESET-UUO*));
%13 (* 14. NO LIBRARIES NEEDED IN PASSGO.*)
IF library[fortransy].called AND fortran_enviroment THEN
BEGIN (* SET-UP FOR FORTRAN-STYLE I/O *)
macro4(202B(*MOVEM*),newreg,newreg,0);
macro4(202B(*MOVEM*),basis,newreg,-1);
macro4(202B(*MOVEM*),topp,newreg,-2);
support(fortranreset);
generate_word(no,0,0);
macro3(554B(*HLRZ*),reg1,jbsa);
macro4(200B(*MOVE*),newreg,reg1,-1);
macro4(200B(*MOVE*),basis,reg1,-2);
macro4(200B(*MOVE*),topp,reg1,-3)
END;
(* 14.*) \
IF NOT debug AND runtime_check THEN
BEGIN
macro3(551B(*HRRZI*),reg1,110B); (*ENABLE OVERFLOW*)
macro3(047B,reg1,16B(*APRENB-UUO*))
END
END;
regc := regin + 1; lparmptr := parmptr;
IF %13 external OR \ (parmptr = NIL) (* 14.*) THEN
BEGIN
alfaconstant(programname);
name_address := ic;
macro2(551B(*HRRZI*),regc+2); deposit_constant(strg,gattr)
END;
%13 (* 14.*)
IF NOT external THEN
(* 14.*) \
BEGIN
IF parmptr <> NIL THEN
name_address := ic;
WHILE lparmptr <> NIL DO
WITH lparmptr↑ DO
BEGIN
IF fileidptr <> NIL THEN
WITH fileidptr↑ DO (* CODE TO CALL GETPARAMETER FOR THE FILE NAMES.*)
BEGIN
alfaconstant(programname);
macro2(551B(*HRRZI*),regc+2); deposit_constant(strg,gattr);
macro3r(551B(*HRRZI*),regc,vaddr);
alfaconstant(name);
macro2(551B(*HRRZI*),regc+1); deposit_constant(strg,gattr);
IF NOT inputfile THEN
macro2(400B(*SETZ*),regc+3)
ELSE
macro3(551B(*HRRZI*),regc+3,1);
support(readpgmparameter)
END
ELSE
error_with_text(264,fileid);
lparmptr := nextptp
END;
%24 (* 21. CALL TO SETTIME *)
SUPPORT(STARTCLOCK);
(* 21.*) \
FOR i := 1 TO 4 DO macro2(400B(*SETZ*),regc+i);
IF NOT inputpar THEN (* OPEN FILE INPUT IF NOT DECLARED AS PARAMETER *)
BEGIN
macro3r(551B(*HRRZI*),regc,stdfileptr[1]↑.vaddr);
support(resetfile);
END;
IF outputwrite AND NOT outputpar THEN (* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
BEGIN
macro3r(551B(*HRRZI*),regc,stdfileptr[2]↑.vaddr);
support(rewritefile);
END;
macro3r(551B(*HRRZI*),regc,stdfileptr[4]↑.vaddr); (* OPEN TTYOUTPUT *)
macro4(336B(*SKIPN*),0,regc,filbhp);
support(rewritefile);
IF ttyread THEN (* OPEN TTY, IF NEEDED.*)
BEGIN
support(opentty);
alfaconstant('TTY ');
macro2(551B(*HRRZI*),regc+1); deposit_constant(strg,gattr);
macro3r(551B(*HRRZI*),regc,stdfileptr[3]↑.vaddr);
macro4(200B(*MOVE*),regc+5,regc,fildev);
macro3(302B(*CAIE*),regc+5,tty_sixbit);
macro3(550B(*HRRZ*),regc+4,regc+1);
support(resetfile)
END;
%24
IF COUNTING THEN (* 28. PUT THEIR VALUES IN MEMORY*)
BEGIN
LADDRESS := STARTOFCOUNTS;
LCNTP := FIRSTCNTP;
WHILE LCNTP <> NIL DO
WITH LCNTP↑ DO (*FOR EACH SET OF 100*)
BEGIN
IF NEXT = NIL THEN
COUNTTOP := COUNTER - 1
ELSE
COUNTTOP := 100;
FOR INDEX := 1 TO COUNTTOP DO (*FOR EACH BASIC BLOCK*)
BEGIN
MACRO3(505B(*HRLI*),REGIN,LINEINFO[INDEX].LINE);
MACRO3(541B(*HRRI*),REGIN,LINEINFO[INDEX].PAGE);
MACRO4(202B(*MOVEM*),REGIN,0,LADDRESS);
MACRO4(402B(*SETZM*),0,0,LADDRESS+1);
LADDRESS := LADDRESS + 2;
END;
LCNTP := NEXT;
END;
END;
\
macro3(552B(*HRRZM*),basis,debug_stackbottom + system_low_start);
macro3(332B(*SKIPE*),reg0,debug_initialization + system_low_start);
macro3(256B(*XCT*),reg0,debug_initialization + system_low_start);
macro3r(254B(*JRST*),reg0,main_start);
IF debug THEN support(loaddebug)
END
END;
codeend := ic;
lksp:= firstkonst; (* VALUES OF THE CONSTANTS *)
WHILE lksp <> NIL DO
WITH lksp↑,constptr↑ DO
BEGIN
kaddr:= ic;
WITH icchange DO
BEGIN
icval := ic; selfcsp :=iccsp
END;
nocode := false;
CASE cclass OF
int,
bptr,
reel:
ic := ic + 1 ;
pset:
ic := ic + 2 ;
strd,
strg:
ic := ic + (slgth+4) DIV 5
END (*CASE*);
lksp := nextkonst
END (*WITH , WHILE*);
ldeclscalptr := declscalptr; (* DESCRIPTION OF THE SCALARS *)
WHILE ldeclscalptr <> NIL DO
WITH ldeclscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
BEGIN
ic := ic+2*dimension; vectoraddr := ic; ic := ic + 2
END;
ldeclscalptr := nextscalar
END
ELSE ldeclscalptr := NIL;
IF debug_switch THEN
BEGIN
lcp := display[top].fname;
IF (level > 1) AND ( lcp <> NIL ) THEN
BEGIN
IF lcp↑.selfctp = NIL THEN i:= ic
ELSE i := ord(lcp↑.selfctp);
insert_address(right,idtree,i)
END
END;
IF level = 1 THEN highest_code := ic
END(*LEAVEBODY*);
(*FETCH_BASIS,GET_PARAMETER_ADDRESS,GENERATE_CODE,LOAD,STORE,LOAD_ADDRESS*)
PROCEDURE fetch_basis(VAR fattr: attr); (* CODE TO PUT IN INDEXR THE BASIS OF A SUBSTRUCTURE *)
VAR
p,q: integer;
BEGIN (*FETCH_BASIS*)
WITH fattr DO
IF vlevel>1 THEN
BEGIN
p := level - vlevel;
IF p=0 THEN
IF indexr=0 THEN indexr := basis
ELSE macro3(270B(*ADD*),indexr,basis)
ELSE
BEGIN
macro4(550B(*HRRZ*),reg1,basis,-1);
FOR q := p DOWNTO 2 DO
macro4(550B(*HRRZ*),reg1,reg1,-1);
IF indexr=0 THEN indexr := reg1
ELSE macro4(271B(*ADDI*),indexr,reg1,0)
END;
(*WITHIN A WITH-STATEMENT, THERE IS THE POSSIBILITY THAT
FETCH_BASIS WILL BE ACTIVATED TWO TIMES*)
vlevel := 1
END
END (*FETCH_BASIS*);
PROCEDURE get_parameter_address; (*CODE TO LOAD THE ADDRESS OF A FORMAL PARAMETER*)
BEGIN (*GET_PARAMETER_ADDRESS*)
fetch_basis(gattr);
WITH gattr DO
BEGIN
increment_regc;
macro5(vrelbyte,200B(*MOVE*),regc,indexr,dplmt);
indexr := regc; vrelbyte:= no;
indbit := 0; vlevel := 1; dplmt := 0
END
END (*GET_PARAMETER_ADDRESS*);
PROCEDURE generate_code(finstr: instrange; fac: acrange; VAR fattr: attr);
VAR
linstr: instrange;
lregc: acrange;
lattr: attr;
lrelbyte: relbyte;
labs: integer;
BEGIN (*GENERATE_CODE*)
lrelbyte := right;
WITH fattr DO
IF typtr<>NIL THEN
BEGIN
CASE kind OF
cst:
IF typtr=realptr THEN
BEGIN
macro3(finstr,fac,0); deposit_constant(reel,fattr)
END
ELSE
IF typtr↑.form=scalar THEN
WITH cval DO
BEGIN
IF ival = -maxint - 1 THEN labs := maxint
ELSE labs := abs(ival);
IF ((ival >= 0) AND (ival <= maxaddr))
OR
((labs <= hwcstmax+1) AND (finstr = 200B(*MOVE*))) THEN
BEGIN
IF finstr=200B(*MOVE*) THEN
IF ival < 0 THEN finstr := 561B(*HRROI*)
ELSE finstr := 551B(*HRRZI*)
ELSE
IF (finstr>=311B) AND (finstr <= 317B) THEN finstr := finstr - 10B (*E.G. CAML --> CAIL*)
ELSE finstr := finstr+1;
macro3(finstr,fac,ival)
END
ELSE
BEGIN
macro3(finstr,fac,0); deposit_constant(int,fattr)
END
END
ELSE
IF typtr=nilptr THEN
BEGIN
IF finstr=200B(*MOVE*) THEN finstr := 551B(*HRRZI*)
ELSE
IF (finstr>=311B) AND (finstr<=317B) THEN finstr := finstr-10B
ELSE finstr := finstr+1;
macro3(finstr,fac,377777B)
END
ELSE
IF typtr↑.form=power THEN
BEGIN
macro3(finstr,fac,0); macro3(finstr,fac-1,0); deposit_constant(pset,fattr)
END
ELSE
IF typtr↑.form=arrays THEN
IF typtr↑.size = 1 THEN
BEGIN
macro3(finstr,fac,0); deposit_constant(strg,fattr)
END
ELSE
IF typtr↑.size = 2 THEN
BEGIN
fattr.cval.valp↑.cclass := strd;
macro3(finstr,fac,0); macro3(finstr,fac-1,0); deposit_constant(strd,fattr)
END;
varbl:
BEGIN
fetch_basis(fattr); lregc := fac;
IF (indexr>regin) AND (indexr<=regcmax) AND ((packfg<>notpack) OR (finstr=200B(*MOVE*))) THEN
IF (typtr↑.size = 2) AND loadnoptr THEN lregc := indexr+1
ELSE lregc := indexr
ELSE
IF (packfg<>notpack) AND (finstr<>200B(*MOVE*)) THEN
BEGIN
increment_regc; lregc := regc
END;
CASE packfg OF
notpack:
BEGIN
IF (typtr↑.size = 2) AND loadnoptr THEN
BEGIN
macro5(vrelbyte,finstr,lregc,indexr,dplmt+1);
macro5(vrelbyte,finstr,lregc-1,indexr,dplmt)
END
ELSE macro(vrelbyte,finstr,lregc,indbit,indexr,dplmt)
END;
packk:
BEGIN
IF vclass = field THEN
BEGIN
WITH lattr, cval, byte DO
BEGIN
kind := cst;
cval.byte := fattr.vbyte;
ibit := ord(fattr.vrelbyte);
ireg := fattr.indexr;
reladdr := reladdr + fattr.dplmt
END;
macro2(135B(*LDB*),lregc); deposit_constant(bptr,lattr)
END
ELSE
BEGIN
macro5(vrelbyte,551B(*HRRZI*),reg1,indexr,dplmt);
IF (bpaddr>regin) AND (bpaddr<=regcmax) THEN
IF (indexr<=regin) OR (bpaddr<indexr) THEN lregc := bpaddr
ELSE lregc := indexr;
IF bpaddr < high_start THEN lrelbyte := no;
macro5(lrelbyte,135B(*LDB*),lregc,0,bpaddr)
END
END;
hwordl:
macro5(vrelbyte,554B(*HLRZ*),lregc,indexr,dplmt);
hwordr:
macro5(vrelbyte,550B(*HRRZ*),lregc,indexr,dplmt)
END (*CASE*);
IF (finstr<>200B(*MOVE*)) AND (packfg<>notpack) THEN macro3(finstr,fac,lregc)
ELSE fac := lregc
END;
expr:
IF finstr <> 200B(*MOVE*) THEN
BEGIN
macro3(finstr,fac,reg);
IF typtr↑.size = 2 THEN macro3(finstr,fac-1,reg-1)
END
END (*CASE*);
kind := expr; reg := fac
END
END (*GENERATE_CODE*);
PROCEDURE load(VAR fattr: attr); (*CODE TO PUT THE VALUE OF FATTR IN A REGISTER*)
VAR
linstr: instrange;
BEGIN (*LOAD*)
WITH fattr DO
IF typtr<>NIL THEN
IF kind<>expr THEN
BEGIN
increment_regc ; linstr := 200B(*MOVE*);
IF (typtr↑.size = 2) AND loadnoptr THEN increment_regc ;
generate_code(linstr,regc,fattr); regc := reg
END
END (*LOAD*) ;
PROCEDURE store(fac: acrange; VAR fattr: attr); (*CODE TO STORE IN MEMORY THE VALUE IN FAC*)
VAR
lattr: attr; lattrc: attr; lrelbyte: relbyte;
BEGIN (*STORE*)
lattr := fattr; lrelbyte := right;
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
fetch_basis(lattr);
CASE packfg OF
notpack:
BEGIN
IF typtr↑.size = 2 THEN
BEGIN
macro5(vrelbyte,202B(*MOVEM*),fac,indexr,dplmt+1); fac := fac-1
END;
macro(vrelbyte,202B(*MOVEM*),fac,indbit,indexr,dplmt)
END;
packk:
IF vclass = field THEN
BEGIN
WITH lattrc, cval, byte DO
BEGIN
kind := cst;
cval.byte := lattr.vbyte;
ibit := ord(lattr.vrelbyte);
ireg := lattr.indexr;
reladdr := reladdr + lattr.dplmt
END;
macro2(137B(*DPB*),fac); deposit_constant(bptr,lattrc)
END
ELSE
BEGIN
macro5(vrelbyte,551B(*HRRZI*),reg1,indexr,dplmt);
IF bpaddr < high_start THEN lrelbyte := no;
macro5(lrelbyte,137B(*DPB*),fac,0,bpaddr)
END;
hwordl:
macro5(vrelbyte,506B(*HRLM*),fac,indexr,dplmt);
hwordr:
macro5(vrelbyte,542B(*HRRM*),fac,indexr,dplmt)
END (*CASE*)
END (*WITH*)
END (*STORE*) ;
PROCEDURE load_address; (*CODE TO PUT THE ADDRESS OF GATTR IN A REGISTER*)
BEGIN (*LOAD_ADDRESS*)
increment_regc ;
BEGIN
WITH gattr DO
IF typtr <> NIL THEN
BEGIN
CASE kind OF
cst:
IF string(typtr) THEN
BEGIN
macro3(551B(*HRRZI*),regc,0);
deposit_constant(strg,gattr)
END
ELSE error(171);
varbl:
BEGIN
IF (indexr>regin) AND (indexr <= regcmax) THEN regc := indexr;
fetch_basis(gattr);
CASE packfg OF
notpack:
macro(vrelbyte,551B(*HRRZI*),regc,indbit,indexr,dplmt);
packk,hwordl,hwordr:
error(357)
END;
%13 (* 14. EXTERNAL IS SUPPRESSED FROM PASSGO.*)
IF typtr↑.form = files THEN
IF last_file <> NIL THEN
WITH last_file↑ DO
IF (vlev = 0) AND external THEN
BEGIN
vaddr := ic-1; code_reference↑[cix] := externref
END
(* 14.*) \
END;
expr:
error(171)
END;
kind := varbl; dplmt := 0; indexr:=regc; indbit:=0; vrelbyte := no; vclass := vars
END
END
END (*LOAD_ADDRESS*) ;
(* WRITE_MACHINE_CODE[ AND ITS PARTS. *)
PROCEDURE write_machine_code(write_flag:write_form);
%13 (* 18.*)
TYPE
bigalfa = PACKED ARRAY[1..20] OF char ;
(* 18.*) \
VAR
%13 llist_code, put_code_array: boolean; (* 14.*) \
%13 lic, licmod4: addrrange; (* 18.*) \
space_c, space_w: integer;
%13 (* 14. LIST_CODE DOES NOT GO IN PASSGO.*)
PROCEDURE new_line;
BEGIN (*NEW_LINE*)
licmod4 := lic MOD 4;
IF (licmod4 = 0) AND list_code AND (lic > 0) THEN
BEGIN
writeln(list);
WITH relocation_block DO
BEGIN
IF item = item_1 THEN write(list, lic:6:o, showrelo[relocator[0] = right])
ELSE write(list,' ':7)
END
END
END (*NEW_LINE*) ;
PROCEDURE put_relocatable_code; (* 18.*)
VAR
i: integer;
BEGIN (*PUT_RELOCATABLE_CODE*)
WITH relocation_block DO
BEGIN
IF ((count > 1) OR (item <> item_1)) AND (count > 0) THEN
BEGIN
FOR i:= count+1 TO 18 DO relocator[i-1] := no;
FOR i:= 1 TO count+2 DO
BEGIN
object↑:= component[i];
put(object)
END
END;
count := 0
END
END (*PUT_RELOCATABLE_CODE*);
PROCEDURE write_block_start(frelbyte: relbyte; flic: addrrange; fitem: addrrange);
VAR
change: PACKED RECORD
CASE boolean OF
true: (wkonst: integer);
false:(wlefthalf: addrrange; wrighthalf: addrrange)
END;
BEGIN (*WRITE_BLOCK_START*)
WITH relocation_block , change DO
BEGIN
IF count <> 0 THEN put_relocatable_code;
item := fitem;
lic := flic;
IF item = item_1 THEN
BEGIN
wlefthalf:= 0;
wrighthalf:= lic;
code[0]:= wkonst;
relocator[0] := frelbyte;
count:= 1
END
END
END (*WRITE_BLOCK_START*);
(* 18. PASCAL VERSION OF WRITE_WORD.*)
PROCEDURE write_word(frelbyte: relbyte; fword: integer);
VAR
change: PACKED RECORD
CASE boolean OF
true: (wkonst: integer);
false:(wlefthalf: addrrange; wrighthalf: addrrange)
END;
BEGIN (*WRITE_WORD*)
WITH change DO
BEGIN
wkonst := fword;
WITH relocation_block DO
BEGIN
IF count = 0 THEN write_block_start(relocator[0],lic,item);
code[count]:= fword;
IF NOT put_code_array THEN
BEGIN
IF frelbyte IN [left,both] THEN
IF (wlefthalf = 0) OR (wlefthalf = 377777B) THEN
IF frelbyte = both THEN frelbyte := right
ELSE frelbyte := no;
IF frelbyte IN [right,both] THEN
IF (wrighthalf = 0) OR (wrighthalf = 377777B) THEN
IF frelbyte = both THEN frelbyte := left
ELSE frelbyte := no
END;
relocator[count]:= frelbyte;
count := count+1;
IF count = 18 THEN put_relocatable_code
END;
IF llist_code THEN
BEGIN
new_line;
IF lic > 0 THEN
IF licmod4 = 0 THEN write(list,' ':13)
ELSE write(list,' ':11,' ':space_w);
IF write_flag > write_fileblocks THEN write(list,' ':7)
ELSE write(list,wlefthalf:6:o, showrelo[ frelbyte IN [left,both] ] );
write(list,wrighthalf:6:o, showrelo[ frelbyte IN [right,both] ], ' ':3)
END;
lic := lic + 1;
space_w := 2
END
END (*WRITE_WORD*);
(* 18.*) \
%24 (* 18. PASSGO VERSION OF WRITE_WORD.*)
PROCEDURE WRITE_WORD (FWORD: INTEGER);
BEGIN
USERPROG.EXECODE [EXECODECOUNT] := FWORD;
EXECODECOUNT := EXECODECOUNT + 1;
IF EXECODECOUNT > MAXCODE THEN
BEGIN
ERROR (412);
EXECODECOUNT := 1;
END;
SPACE_W := 2;
END;
(* 18.*) \
%13 (* 18.*)
FUNCTION radix50( fname: alfa): radixrange;
VAR
i: integer; c: char; octalcode, radixvalue: radixrange;
BEGIN (*RADIX50*)
radixvalue:= 0;
i:=1; c := fname[1];
WHILE (c <> ' ') AND (i <= 6) DO
BEGIN
IF c IN digits THEN octalcode:= ord(c)-ord('0')+1
ELSE
IF c IN letters THEN octalcode:= ord(c)-ord('A')+11
ELSE
IF c = '.' THEN octalcode:= 37
ELSE
IF c = '$' THEN octalcode:= 38
ELSE
IF c = '%' THEN octalcode:= 39;
radixvalue:= radixvalue*50B+octalcode; i:=i+1; c := fname[i]
END;
radix50:= radixvalue
END (*RADIX50*);
(* 18.*) \
PROCEDURE write_pair( %13 frelbyte: relbyte; \ faddr1, faddr2: addrrange); (* 18.*)
BEGIN (*WRITE_PAIR*)
WITH change DO
BEGIN
wlefthalf:= faddr1;
wrighthalf:= faddr2;
write_word( %13 frelbyte, \ wkonst) (* 18.*)
END
END (*WRITE_PAIR*);
%13 (* 18.*)
PROCEDURE write_identifier( fflag: flagrange; fsymbol: alfa);
BEGIN (*WRITE_IDENTIFIER*)
llist_code := false;
WITH change DO
BEGIN
IF list_code AND (write_flag > write_hiseg) THEN
BEGIN
IF lic > 0 THEN
BEGIN
IF lic MOD 4 = 0 THEN
BEGIN
writeln(list); write(list,' ':7)
END;
write(list,' ':13)
END;
write(list,fsymbol:6,' ':11)
END;
IF fflag <> sixbit_symbol THEN
BEGIN
flag:= fflag; symbol:= radix50(fsymbol)
END;
write_word(no,wkonst);
llist_code := list_code
END
END (*WRITE_IDENTIFIER*);
PROCEDURE write_first_line ;
BEGIN (*WRITE_FIRST_LINE*)
IF list_code THEN
BEGIN
writeln(list);
licmod4 := lic MOD 4;
IF licmod4 > 0 THEN
write(list,(lic-licmod4):6:o,showrelo[relocation_block.relocator[0] = right],' ':licmod4*30)
END
END (*WRITE_FIRST_LINE*);
PROCEDURE write_header(ftext: bigalfa);
BEGIN (*WRITE_HEADER*)
IF list_code THEN
BEGIN
writeln(list); writeln(list); write(list,ftext:16,':',' ':3); lic := 0
END
END (*WRITE_HEADER*);
(* 18.*) \
PROCEDURE write_constant(fcst: cstclass);
VAR
i, j: integer; lrelbyte: relbyte;
BEGIN (*WRITE_CONSTANT*)
WITH change DO
BEGIN
IF (fcst = bptr) AND (wbyte.ibit <> 0) THEN
BEGIN
wbyte.ibit := 0; lrelbyte := right
END
ELSE lrelbyte := no;
%13 (* 14. LIST_CODE IS NOT IN PASSGO.*)
IF list_code THEN
BEGIN
new_line;
IF licmod4 = 0 THEN write(list,' ':8)
ELSE write(list,' ':6,' ':space_c);
CASE fcst OF
int:
write(list,'[',' ':10,wkonst,']');
reel:
write(list,'[',' ':5,wreal,']');
strd,
strg:
BEGIN
write(list,'[',' ':15,''''); j := 0;
FOR i := 1 TO 5 DO
IF NOT (wstring[i] IN [' '..'_']) THEN j := j + 1
ELSE write(list,wstring[i]);
write(list,'''',' ':j,']')
END;
pset:
write(list,'[',' ':10,wkonst:12:o,']');
bptr:
WITH wbyte DO
write(list, 'POINT ', sbits:2, ', ',
reladdr:5:o, showrelo[(lrelbyte = right)], '(',
ireg:2:o, '),', 35-pbits:2)
END
END;
(* 14.*) \
write_word( %13 lrelbyte, \ wkonst); (* 18.*)
space_c := 0
END
END (*WRITE_CONSTANT*);
PROCEDURE code_for_fileblocks;
VAR
stopptr, lfileptr: ftp;
i: integer;
filblockadr: addrrange;
%24 ATASTDFILE: BOOLEAN; (* 21.*) \
(* IMPLEMENTATION OF FILES IN DECSYSTEM-10 PASCAL
FILE TYPE PACKED UNPACKED
------------------------------------------------
(SUBRANGE OF) ASCII-MODE, BINARY-MODE,
CHAR FORMATTED I/O, STANDARD I/O,
"UPPER CASE", "FULL BOARD"
LINENUMBERS &
PAGEMARKS
(SUBRANGE OF) ASCII-MODE, AS ABOVE
ASCII STANDARD I/O,
. "FULL BOARD"
OTHER TREATED AS ABOVE
. AS UNPACKED
*)
BEGIN (*CODE_FOR_FILEBLOCKS*)
lfileptr:= fileptr;
%13 (* 14. *)
IF NOT external THEN stopptr := NIL
ELSE
stopptr := sfileptr;
(* 14.*) \
%24 (* 21.*)
STOPPTR := NIL;
ATASTDFILE := LFILEPTR = SFILEPTR;
(* 21.*) \
WHILE lfileptr <> stopptr DO
WITH lfileptr↑, fileident↑, change DO
IF idtype=NIL THEN
BEGIN
error(171); lfileptr:=stopptr
END
ELSE
BEGIN
%24 (* 21.*)
IF ATASTDFILE THEN
EXECODECOUNT := VADDR - SYSTEM_LOW_START
ELSE
EXECODECOUNT := VADDR - USERAREASTART;
(* 21.*) \
filblockadr := vaddr;
%13 write_block_start(right,filblockadr,item_1); (* 18.*) \
%13 write_first_line; (* 14.*) \
wlefthalf := idtype↑.file_form;
wrighthalf := filblockadr + filcmp;
write_word( %13 right, \ wkonst) ; (* 18.*)
write_word( %13 no, \ 0) ; write_word( %13 no, \ 0) ; (*RESERVE LOCATIONS FOR FILEOF AND FILEOL*) (* 18.*)
wkonst := 0;
winstr.instr := 50B (*OPEN*) ; winstr.ac := channel ;
winstr.address := filblockadr + filsta ;
write_word( %13 right, \ wkonst) (*FILOPN*) ; (* 18.*)
winstr.instr := 76B (*LOOKUP*) ; winstr.address := filblockadr + filnam ;
write_word( %13 right, \ wkonst) ; (* 18.*)
winstr.instr := 77B (*ENTER*) ;
write_word( %13 right, \ wkonst) ; (* 18.*)
winstr.address := 0 ;
winstr.instr := 56B (* IN*) ; write_word( %13 no, \wkonst) ; (* 18.*)
winstr.instr := 57B (*OUT*) ; write_word( %13 no, \wkonst) ; (* 18.*)
winstr.instr := 70B (*CLOSE*) ; write_word( %13 no, \wkonst) ; (* 18.*)
write_word( %13 no, \ idtype↑.file_mode); (* 18.*)
IF (name = 'TTYOUTPUT ') OR (name = 'TTY ') THEN wlefthalf := tty_sixbit
ELSE wlefthalf := dsk_sixbit;
wrighthalf := 0;
write_word( %13 no, \ wkonst); (* 18.*)
write_word( %13 no, \ 0) ; (*BUFFERHEADER ADDRESS INSERTED DURING RESET OR REWRITE*) (* 18.*)
FOR i := 1 TO 6 DO wsixbit[i] := ord( name[i] ) - 40B ;
write_word( %13 no, \ wkonst) ; (* 18.*)
wkonst := 0 ;
FOR i := 1 TO 3 DO wsixbit[i] := ord( name[i+6] ) - 40B ;
write_word( %13 no, \ wkonst) ; (* 18.*)
FOR i := 1 TO 6 DO write_word( %13 no, \ 0 ) (*ZERO IN FILPROT, FILPPN, FILBFH, FILBTP, FILBTC,FILLNR*) ;
(* 18.*)
wlefthalf := - idtype↑.filtype↑.size ; wrighthalf := filblockadr + filcmp ;
write_word( %13 right, \ wkonst) (*FILCNT*) ; (* 18.*)
FOR i := 1 TO idtype↑.filtype↑.size DO write_word( %13 no, \ 0 ) (*CLEAR COMPONENT LOCATIONS *) ;
(* 18.*)
lfileptr := nextftp;
%24 (* 21.*)
IF LFILEPTR = SFILEPTR THEN
ATASTDFILE := TRUE;
(* 21.*) \
END;
END (*CODE_FOR_FILEBLOCKS*);
PROCEDURE code_for_instructions;
VAR
i, j, nn: integer;
lbyte: bpointer; ldeclscalptr: stp; lfconst: ctp;
lrelbyte: relbyte; lfirstkonst: ksp; lreference: coderefs;
string: ARRAY[1..6] OF char;
BEGIN (*CODE_FOR_INSTRUCTIONS*)
%13 (* 14. LIST_CODE NOT IN PASSGO.*)
llist_code:= false;
IF list_code THEN writebuffer;
(* 14.*) \
IF lastbtp <> NIL THEN (* WRITE THE BYTEPOINTERS *)
BEGIN
%13 write_block_start(right,lastbtp↑.arraysp↑.arraybpaddr,item_1); (* 18.*) \
%13 write_first_line; (* 14.*) \
WHILE lastbtp <> NIL DO
BEGIN
WITH lastbtp↑, arraybps[bitsize] DO
BEGIN
lbyte := abyte;
IF state = calculated THEN
BEGIN
nn := bytemax; state:= used
END
ELSE nn:=0
END;
FOR i:=1 TO nn DO
BEGIN
WITH change DO
BEGIN
wbyte := lbyte; write_constant(bptr)
END;
WITH lbyte DO pbits := pbits - sbits
END (*FOR*);
lastbtp := lastbtp↑.last
END (* WHILE*)
END (*LASTBTP<>NIL*) ;
%13 (* 14. AND 18.*)
put_code_array := true; (* WRITE THE INSTRUCTION CODE *)
write_block_start(right,codeend-cix-1,item_1);
write_first_line;
IF list_code AND (licmod4 <> 0) THEN write(list,' ':2);
(* 14. AND 18.*) \
FOR i := 0 TO cix DO
WITH code_array↑, instruction[i] DO
BEGIN
lrelbyte := code_relocation↑[i];
lreference := code_reference↑[i];
IF (lreference IN [externref,constref,forwardref,gotoref,pointref,saveref,debugref]) AND (address = 0) THEN lrelbyte := no;
%13 (* 14.*)
IF list_code THEN
BEGIN
new_line;
IF licmod4 = 0 THEN write(list,' ':8)
ELSE write(list,' ':6);
CASE lreference OF
noinstr:
WITH halfword[i] DO
write(list,' ':5,lefthalf :6:o, showrelo[lrelbyte IN [left,both]],
righthalf:6:o, showrelo[lrelbyte IN [right,both]],' ':5);
OTHERS:
BEGIN
unpack(mnemonics[(instr+9) DIV 10],string,1,((instr+9) MOD 10)*6+1,6);
write(list,string:6, ' ',ac:2:o,', ', showibit[indbit],
address:6:o, showrelo[lrelbyte IN [right,both]]);
IF inxreg > 0 THEN write(list,'(',inxreg:2:o,')',showref[lreference])
ELSE write(list,' ':4,showref[lreference])
END
END (*CASE*)
END;
(* 14.*) \
write_word( %13 lrelbyte, \ word[i]) (* 18.*)
END (*FOR *) ;
%13 put_code_array := false; (* 18.*) \
IF (firstkonst <> NIL) OR (declscalptr <> NIL) THEN
BEGIN (* WRITE THE VALUES OF THE CONSTANTS *)
lfirstkonst := firstkonst;
%13 (* 14. AND 18.*)
write_block_start(right,lic,item_1);
write_first_line;
IF list_code AND (licmod4 <> 0) THEN write(list,' ':2);
(* 14. AND 18.*) \
WHILE lfirstkonst <> NIL DO
BEGIN
WITH lfirstkonst↑.constptr↑, change DO
BEGIN
CASE cclass OF
int,
reel:
wkonst := intval;
pset:
BEGIN
wkonst := intval; write_constant(cclass);
wkonst := intval1
END;
bptr:
wbyte := byte;
strd,
strg:
BEGIN
j :=0; wkonst := 0;
FOR i := 1 TO slgth DO
BEGIN
j := j+1;
wstring[j] := sval[i];
IF j=5 THEN
BEGIN
j := 0;
write_constant(cclass);
wkonst := 0
END
END
END
END;
IF NOT (cclass IN [strd,strg]) OR (j <> 0) THEN write_constant(cclass)
END;
lfirstkonst := lfirstkonst↑.nextkonst
END (*WHILE*) ;
ldeclscalptr := declscalptr; (* WRITE THE DESCRIPTIONS OF SCALARS *)
WHILE ldeclscalptr <> NIL DO
WITH ldeclscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
BEGIN
lfconst := fconst;
WHILE lfconst <> NIL DO
WITH lfconst↑ DO
BEGIN
FOR j := 0 TO 1 DO
WITH change DO
BEGIN
wkonst := 0;
FOR i := 1 TO 5 DO
wstring[i] := name[i+j*5];
write_constant(strd)
END;
lfconst := next
END
END;
ldeclscalptr := nextscalar
END
ELSE ldeclscalptr := NIL
END;
IF level = 1 THEN
if counting then
begin
jump_address := gotomarkers;
gotomarkers := gotomarkers + 2 * jumper
end
else (*not counting*)
BEGIN
jump_address := lcmain;
lcmain := lcmain + 2 * jumper
END;
IF NOT debug AND (level = 1) THEN
BEGIN
%13 (* 14.*)
llist_code := list_code;
IF list_code THEN
BEGIN
writeln(list); write(list,debug_save:6:o,'''',' ':13)
END;
(* 14.*) \
%13 write_block_start(right,debug_save,item_1); (* 18.*) \
FOR i := debug_save TO debug_programname DO
write_word( %13 no, \ 0) (* 18.*)
END
END (*CODE_FOR_INSTRUCTIONS*);
%13 (* 14.*)
PROCEDURE code_for_globals;
VAR
i, j: integer;
BEGIN (*CODE_FOR_GLOBALS*)
IF list_code AND (fglobptr <> NIL) THEN writebuffer;
WHILE fglobptr <> NIL DO
WITH fglobptr↑ DO
BEGIN
j := fcix ;
write_block_start(right,firstglob,item_1);
write_first_line;
FOR i := firstglob TO lastglob DO
BEGIN
change.winstr := code_array↑.instruction[j] ; j := j + 1 ;
write_word(no,change.wkonst)
END ;
fglobptr := nextglobptr
END
END (*CODE_FOR_GLOBALS*);
(* 14.*) \
PROCEDURE code_for_debug;
CONST
maxsize (*OF CONSTANT-, STRUCTURE-, AND IDENTIFIER-RECORD*) = 24 (*WORDS*) ;
TYPE
recordform = (unspecific, const_rec, struct_rec,
ident_rec, debug_rec);
VAR
lnlk : nlk;
lcp: ctp;
lsize: 1..maxsize; run1: boolean;
relarray, relempty: ARRAY[1..maxsize] OF relbyte;
icchange: PACKED RECORD
CASE integer OF
1:(icval: addrrange);
2:(iccsp: csp);
3:(icctp: ctp);
4:(icstp: stp)
END;
recordchange: PACKED RECORD
CASE recordform OF
unspecific: (word:ARRAY[1..maxsize] OF integer);
const_rec: (string1: PACKED ARRAY[1..strglgth] OF char);
struct_rec: (structrec: structure);
ident_rec: (identrec: identifier);
debug_rec: (debugrec: debentry)
END;
PROCEDURE write_record(record_form: recordform);
VAR
i, j: integer;
BEGIN (*WRITE_RECORD*)
%13 llist_code := false; (* 14.*) \
space_c := 2;
CASE record_form OF
ident_rec :
j := 2;
const_rec :
j := lsize;
OTHERS :
j := 0;
END;
IF j <> 0 THEN
BEGIN
FOR i := 1 TO j DO
BEGIN
change.wkonst := recordchange.word[i];
write_constant(strg)
END;
space_w := 0
END;
%13 llist_code := list_code; (* 14.*) \
FOR i := j + 1 TO lsize DO write_word( %13 relarray[i], \ recordchange.word[i] ) (* 18.*)
END (*WRITE_RECORD*);
PROCEDURE copycsp(fcsp:csp);
BEGIN (*COPYCSP*)
IF fcsp <> NIL THEN
WITH fcsp↑ DO
BEGIN
IF cclass IN [strg,strd] THEN lsize := (slgth + 4) DIV 5
ELSE error(171);
IF run1 THEN
BEGIN
IF selfcsp = NIL THEN WITH icchange DO
BEGIN
icval := ic; selfcsp := iccsp;
nocode := true;
ic := ic + lsize
END
END
ELSE
IF nocode THEN
BEGIN
recordchange.string1 := fcsp↑.sval;
relarray := relempty;
write_record(const_rec); nocode := false
END
END (*WITH FCSP↑*)
END (*COPYCSP*);
PROCEDURE copystp(fsp:stp); FORWARD;
PROCEDURE copyctp(fcp:ctp);
BEGIN (*COPYCTP*)
IF fcp <> NIL THEN
WITH fcp↑ DO
IF run1 AND (selfctp=NIL) OR NOT run1 AND nocode THEN
BEGIN
lsize := idrecsize[klass];
IF run1 THEN
WITH icchange DO
BEGIN
icval := ic;
selfctp := icctp; nocode := true;
ic := ic + lsize
END (* RUN1 *)
ELSE
WITH recordchange DO
BEGIN
relarray := relempty;
identrec := fcp↑;
WITH identrec DO
BEGIN
IF llink<>NIL THEN llink:=llink↑.selfctp;
IF rlink<>NIL THEN rlink:=rlink↑.selfctp;
relarray[3] := both;
IF next <>NIL THEN next := next↑.selfctp;
relarray[4] := both;
IF idtype <> NIL THEN
BEGIN
CASE klass OF
konst:
IF idtype↑.form > pointer THEN
BEGIN
values.valp := values.valp↑.selfcsp;
relarray[6] := right
END
ELSE
IF idtype = realptr THEN
BEGIN
change.wreal := values.valp↑.rval;
values.ival := change.wkonst
END;
vars:
BEGIN
IF vlev < 2 THEN relarray[6] := right;
%13 (* 14.*)
WITH fcp↑ DO
IF (idtype↑.form = files) AND (vlev = 0) AND external THEN vaddr := ord(selfctp) + 5
(* 14.*) \
END
END (*CASE*);
idtype := idtype↑.selfstp
END
END;
write_record(ident_rec); nocode := false
END (* RUN2 *);
copyctp(llink);
copyctp(rlink);
copystp(idtype);
copyctp(next);
IF (klass = konst) AND (idtype <> NIL) THEN
IF idtype↑.form > pointer THEN copycsp(values.valp)
END (*WITH FCP↑*)
END (*COPYCTP*);
PROCEDURE copystp;
BEGIN (*COPYSTP*)
IF fsp <> NIL THEN
WITH fsp↑ DO
BEGIN
IF run1 AND (selfstp = NIL) OR NOT run1 AND nocode THEN
BEGIN
lsize := strecsize[form];
IF run1 THEN
WITH icchange DO
BEGIN
nocode:=true;
icval := ic; selfstp := icstp;
ic := ic + lsize
END (* RUN1 *)
ELSE
WITH recordchange DO
BEGIN
relarray := relempty; relarray[2] := right;
structrec := fsp↑;
WITH structrec DO
CASE form OF
scalar:
IF scalkind = declared THEN
IF fconst<>NIL THEN fconst:=fconst↑.selfctp;
subrange:
rangetype:=rangetype↑.selfstp;
pointer:
IF eltype <> NIL THEN eltype := eltype↑.selfstp;
power:
elset := elset↑.selfstp;
arrays:
BEGIN
aeltype := aeltype↑.selfstp;
inxtype := inxtype↑.selfstp; relarray[3] := both
END;
records:
BEGIN
IF fstfld <> NIL THEN fstfld := fstfld↑.selfctp;
IF recvar <> NIL THEN
BEGIN
recvar := recvar↑.selfstp; relarray[3] := left
END
END;
files:
filtype := filtype↑.selfstp;
tagfwithid,
tagfwithoutid:
BEGIN
fstvar := fstvar↑.selfstp;
IF form = tagfwithid THEN tagfieldp := tagfieldp↑.selfctp;
relarray[3] := left
END;
variant:
BEGIN
IF subvar <> NIL THEN subvar := subvar↑.selfstp;
IF firstfield <> NIL THEN firstfield := firstfield↑.selfctp;
relarray[3] := both;
IF nxtvar <> NIL THEN nxtvar := nxtvar↑.selfstp
END
END (*CASE*);
write_record(struct_rec); nocode := false
END (*RUN 2*);
CASE form OF
scalar:
IF scalkind = declared THEN copyctp(fconst);
subrange:
copystp(rangetype);
pointer:
copystp(eltype);
power:
copystp(elset);
arrays:
BEGIN
copystp(aeltype);
copystp(inxtype)
END;
records:
BEGIN
copyctp(fstfld);
copystp(recvar)
END;
files:
copystp(filtype);
tagfwithid,
tagfwithoutid:
BEGIN
copystp(fstvar);
IF form = tagfwithid THEN copyctp(tagfieldp)
END;
variant:
BEGIN
copystp(nxtvar);
copystp(subvar);
copyctp(firstfield)
END
END (*CASE*)
END ;
END (* WITH FSP↑ *)
END (*COPYSTP*);
BEGIN (*CODE_FOR_DEBUG*)
FOR i := 1 TO maxsize DO relempty[i] := no;
IF debug_switch THEN
BEGIN
%13 write_first_line; (* 14.*) \
lcp := display[top].fname;
IF level = 1 THEN
BEGIN
debugentry.globalidtree := ic;
IF lcp<>NIL THEN
IF lcp↑.selfctp <> NIL THEN debugentry.globalidtree := ord(lcp↑.selfctp)
END;
FOR run1 := true DOWNTO false DO copyctp(lcp);
lnlk := globnewlink;
WHILE lnlk <> NIL DO
WITH lnlk↑ DO
BEGIN
IF reftype↑.selfstp = NIL THEN FOR run1 := true DOWNTO false DO copystp(reftype);
lnlk := next
END;
IF level = 1 THEN
BEGIN
debugentry.standardidtree := ic;
FOR run1 := true DOWNTO false DO copyctp(display[0].fname)
END;
END (*DEBUG_SWITCH*);
IF level = 1 THEN
BEGIN
WITH debugentry DO
BEGIN
newpager; lastpageelem := pager;
intpoint := intptr↑. selfstp;
realpoint := realptr↑.selfstp;
boolpoint := boolptr↑.selfstp;
charpoint := asciiptr↑.selfstp
END;
pageheadadr := ic;
FOR i:=1 TO debentry_size DO relarray[i] := right;
recordchange.debugrec := debugentry;
ic := ic + debentry_size;
lsize := debentry_size;
write_record(debug_rec);
highest_code := ic;
%13 (* 14.*)
IF list_code THEN
BEGIN
writeln(list); write(list,debug_save:6:o,'''',' ':13)
END;
(* 14.*) \
%13 write_block_start(right, debug_save,item_1); (* 18.*) \
%24 EXECODECOUNT := DEBUG_SAVE; (* 21.*) \
write_word( %13 no, \ 0); (* 18.*)
%13 write_pair(no,260740B(*PUSHJ 17,*),0); (* 18.*) \
%24 WRITE_PAIR(260740B(*PUSHJ 17,*),RUNTIME_SUPPORT.LINK[ENTERDEBUG]); (* 21.*) \
write_pair( %13 right, \ 0,pageheadadr); (* 18.*)
FOR i := 1 TO 3 DO write_word( %13 no, \ 0);
(* 18.*)
%13 write_pair(no,260740B(*PUSHJ, 17*),0); (* 18.*) \
%24 WRITE_PAIR(260740B(*PUSHJ, 17*),RUNTIME_SUPPORT.LINK[INITIALIZEDEBUG]); (* 21.*) \
write_pair( %13 right, \ 0,name_address) (* 18.*)
END (*LEVEL=1*)
END (*CODE_FOR_DEBUG*);
(* PARTS. ]WRITE_MACHINE_CODE. *)
PROCEDURE code_for_control;
VAR
i,j: integer; inlevel: boolean;
checker: ctp;
%24 (* 19. TO BACKPATCH INTERNAL REFERENCES.*)
PROCEDURE WALKCHAIN (WHERE, WHAT: ADDRRANGE);
VAR
TEMPWHERE: INTEGER;
BEGIN
WHERE := WHERE - USERAREASTART;
WITH USERPROG DO
WHILE WHERE > 0 DO
BEGIN
TEMPWHERE := EXEHALFS[WHERE].RIGHTHALF - USERAREASTART;
EXEHALFS[WHERE].RIGHTHALF := WHAT;
WHERE := TEMPWHERE;
END;
END (* WALKCHAIN *);
(* 19. END OF BACKPATCHING.*) \
BEGIN (*CODE_FOR_CONTROL*)
%13 (* 18.*)
CASE write_flag OF
write_internals:
BEGIN
write_header('LINK-CHAIN(S) ');
write_block_start(no,0,item_10);
(* 18.*) \
WHILE globnewlink <> NIL DO
WITH globnewlink↑ DO
BEGIN
%13 write_pair( both , refadr , ord( reftype↑.selfstp )); (* 19.*) \
%24 WALKCHAIN (REFADR, ORD(REFTYPE↑.SELFSTP)); (* 19.*) \
globnewlink := next
END;
inlevel := true;
checker := localpfptr;
WHILE (checker <> NIL) AND inlevel DO
WITH checker↑ DO
IF pflev = level THEN
BEGIN
IF pfaddr <> 0 THEN FOR i := 0 TO maxlevel DO
IF linkchain[i] <> 0 THEN
%13 write_pair(both,linkchain[i],pfaddr-i);
(* 19.*) \
%24 WALKCHAIN(LINKCHAIN[I],PFADDR-I); (* 19.*) \
checker:= pfchain
END
ELSE inlevel := false;
IF level > 1 THEN localpfptr := checker;
WHILE firstkonst <> NIL DO
WITH firstkonst↑, constptr↑ DO
BEGIN
%13 write_pair(both,addr,kaddr); (* 19.*) \
%24 WALKCHAIN (ADDR,KADDR); (* 19.*) \
IF (cclass IN [pset,strd]) AND double_chain THEN
%13 write_pair(both,addr-1,kaddr+1);
(* 19.*) \
%24 WALKCHAIN (ADDR-1,KADDR+1); (* 19.*) \
firstkonst:= nextkonst
END;
inlevel := true;
WHILE (declscalptr <> NIL) AND inlevel DO
WITH declscalptr↑ DO
IF (level = tlev) OR ((level = 1) AND (tlev = 0)) THEN
BEGIN
IF request THEN
%13 write_pair(both,vectorchain,vectoraddr);
(* 19.*) \
%24 WALKCHAIN (VECTORCHAIN,VECTORADDR); (* 19.*) \
declscalptr := nextscalar
END
ELSE inlevel := false;
inlevel := true;
WHILE (last_label <> NIL) AND inlevel DO
WITH last_label↑ DO
IF scope = level THEN
BEGIN
IF goto_chain <> 0 THEN
IF label_address = 0 THEN error_with_text(214,name)
ELSE
%13 write_pair(both,goto_chain,label_address);
(* 19.*) \
%24 WALKCHAIN(GOTO_CHAIN,LABEL_ADDRESS); (* 19.*) \
last_label := next
END
ELSE inlevel := false;
IF level = 1 THEN
BEGIN
j := 0;
FOR i := 1 TO jumper DO
BEGIN
IF jump_table[i] <> 0 THEN
BEGIN
%13 (* 19.*)
write_pair(both,jump_table[i],jump_address + j);
write_pair(both,jump_table[i] + 1, jump_address + j + 1);
(* 19. *) \
%24 (* 19.*)
WALKCHAIN (JUMP_TABLE[I], JUMP_ADDRESS + J);
WALKCHAIN (JUMP_TABLE[I] + 1, JUMP_ADDRESS + J + 1);
(* 19.*) \
j := j + 2
END
END
END
%13 (* 18. THE REST OF IT IS NOT USED IN PASSGO.*)
END;
write_end:
BEGIN
write_header('HIGHSEG-BREAK ');
write_block_start(no,0,item_5);
write_pair(right,0,highest_code);
write_header('LOWSEG-BREAK ');
lic := 0;
write_pair(right,0,lcmain); put_relocatable_code
END;
write_start:
IF NOT external THEN
BEGIN
write_header('START-ADDRESS ');
write_block_start(no,0,item_7);
write_pair(right,0,start_address)
END;
write_entry:
IF external THEN
BEGIN
write_block_start(no,0,item_4);
FOR i := 2 TO entries DO
write_identifier(entry_symbol,entry[i])
END;
write_name:
BEGIN
write_block_start(no,0,item_6);
write_identifier(entry_symbol,programname)
END;
write_hiseg:
BEGIN
llist_code := false;
write_block_start(no,0,item_3);
\
%1 WRITE_PAIR(NO,400000B,400000B) \
%3 write_pair(right,400000B,400000B) \
%13
END
END (*CASE*)
(* 18.*) \
END (*CODE_FOR_CONTROL*) ;
%13 (* 18. NOT NEEDED FOR PASSGO.*)
PROCEDURE code_for_symbols;
VAR
save_list_code: boolean;
switchflag: flagrange; checker: ctp;
BEGIN (*CODE_FOR_SYMBOLS*)
write_header('ENTRY-POINT(S) ');
write_block_start(no,0,item_2);
IF NOT external THEN
BEGIN
write_identifier(local_symbol,programname);
write_pair(right,0,start_address);
END
ELSE
BEGIN
checker := localpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF pfaddr <> 0 THEN
BEGIN
write_identifier(local_symbol,name);
write_pair(right,0,pfaddr)
END;
checker:= pfchain
END;
save_list_code := list_code; list_code := false;
checker := localpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF pfaddr <> 0 THEN
BEGIN
write_identifier(global_symbol,name);
write_pair(right,0,pfaddr)
END;
checker := pfchain
END;
list_code := save_list_code
END;
IF NOT external THEN
BEGIN
switchflag:= global_symbol;
write_header('ENTRY-SYMBOL(S) ');
END
ELSE
BEGIN
switchflag:= extern_symbol; write_header('EXTERN-SYMBOL(S) ')
END;
fileptr := sfileptr;
WHILE fileptr <> NIL DO
WITH fileptr↑, fileident↑ DO
BEGIN
IF vaddr <> 0 THEN
BEGIN
write_identifier(switchflag,name);
write_pair(right,0,vaddr)
END;
fileptr:= nextftp
END;
IF NOT external THEN
write_header('EXTERN-SYMBOL(S) ');
checker:= externpfptr;
WHILE checker <> NIL DO
WITH checker↑ DO
BEGIN
IF linkchain[0] <> 0 THEN
BEGIN
IF pflev = 0 THEN write_identifier(extern_symbol,externalname)
ELSE write_identifier(extern_symbol,name);
write_pair(right,0,linkchain[0])
END;
checker:= pfchain
END;
FOR support_index := first(support_index) TO last(support_index) DO
IF runtime_support.link[support_index] <> 0 THEN
BEGIN
write_identifier(extern_symbol,runtime_support.name[support_index]);
write_pair(right,0,runtime_support.link[support_index])
END;
IF debug THEN
BEGIN
write_identifier(extern_symbol,runtime_support.name[enterdebug]);
write_pair(right,0,debug_stop);
write_identifier(extern_symbol,runtime_support.name[initializedebug]);
write_pair(right,0,debug_initialization)
END;
IF NOT (debug OR external) THEN
BEGIN
write_identifier(extern_symbol,runtime_support.name[overflow]);
write_pair(no,0,jbapr)
END
END (*CODE_FOR_SYMBOLS*) ;
PROCEDURE code_for_libraries;
VAR
i, j, l: integer;
BEGIN (*CODE_FOR_LIBRARIES*)
write_header('LINK-LIBRARIE(S) ');
write_block_start(no,0,item_17);
FOR l := 1 TO 2 DO
BEGIN
FOR i := 1 TO library_index DO
WITH library[library_order[i]] DO
IF called THEN WITH change DO
BEGIN
FOR j := 1 TO 6 DO wsixbit[j] := ord(name[j]) - 40B;
write_identifier(sixbit_symbol,name);
write_pair(no,projnr,prognr);
FOR j := 1 TO 6 DO wsixbit[j] := ord(device[j]) - 40B;
write_identifier(sixbit_symbol,device); lic := lic + 1
END;
i := 1;
FOR language_index := fortransy DOWNTO pascalsy DO
WITH library[language_index] DO
BEGIN
called := (NOT chained AND called) OR ((language_index = pascalsy) AND NOT called);
library_order[i] := language_index; i := i + 1
END;
library_index := 2
END
END (*CODE_FOR_LIBRARIES*);
PROCEDURE coding_counters;
VAR
index: 1..100;
BEGIN (*CODING_COUNTERS*)
IF counter > 1 THEN
WITH change DO
BEGIN
write_block_start(right,lastlcmain,item_1);
FOR index := 1 TO counter - 1 DO
BEGIN
wlefthalf := line_count[index].line;
wrighthalf := line_count[index].page;
write_word(no,wkonst);
wkonst := 0;
write_word(no,wkonst);
END;
END;
END (*CODING_COUNTERS*);
(* 18.*) \
BEGIN (*WRITE_MACHINE_CODE*)
IF NOT errorflag AND NOT no_code_gen THEN
BEGIN (* 22. AVOID CODE GENERATION IN CASE OF AN ERROR.*)
%13 put_code_array := false; (* 18.*) \
space_w := 2; space_c := 0;
%13 llist_code := list_code; (* 18.*) \
CASE write_flag OF
write_fileblocks:
code_for_fileblocks;
%13 (* 14.*)
write_globals :
code_for_globals;
(* 14.*) \
write_code :
code_for_instructions;
write_debug :
code_for_debug;
%13 (* 18.*)
write_symbols :
code_for_symbols;
write_internals,
write_entry,
write_end,
write_start,
write_hiseg,
write_name :
(* 18.*) \
%24 WRITE_INTERNALS : (* 18.*) \
code_for_control;
%13 (* 18.*)
write_library :
code_for_libraries;
write_counters:
coding_counters;
(* 18.*) \
END (*CASE*);
%13 (* 14.*)
IF list_code AND (write_flag > write_hiseg) THEN writeln(list)
(* 14.*) \
END (* IF NOT ERRORFLAG *)
ELSE
%13
IF errorflag THEN \
BEGIN
lastbtp := NIL;
declscalptr := NIL
END;
END (*WRITE_MACHINE_CODE*);
PROCEDURE addnewcounter;
VAR
index: integer;
%24 LCNTP: CNTP; \
BEGIN (*ADDNEWCOUNTER*)
macro3r(350B(*AOS*),0,lcmain+1);
IF hassoslines THEN
BEGIN
linecnt := 0;
FOR index := 1 TO 5 DO
linecnt := linecnt * 10 + ord(linenr[index]) - ord('0');
END;
%13 WITH line_count[counter] DO \
%24 WITH LASTCNTP↑.LINEINFO[COUNTER] DO \
BEGIN
line := linecnt;
page := pagecnt;
END;
counter := counter + 1;
lcmain := lcmain + 2;
IF counter > 100 THEN
BEGIN
%13 write_machine_code(write_counters);
lastlcmain := lcmain;
\
%24
NEW(LCNTP);
LCNTP↑.NEXT := NIL;
LASTCNTP↑.NEXT := LCNTP;
LASTCNTP := LCNTP;
\
counter := 1;
END;
END (*ADDNEWCOUNTER*);
(* STATEMENT[ MAKEREAL, SELECTOR[SUBLOWBOUND] *)
PROCEDURE statement(fsys,statends: setofsys);
TYPE
valuekind = (onregc,onfixedregc,truejmp,falsejmp);
VAR
lcp: ctp; j: integer;
PROCEDURE expression(fsys: setofsys; fvalue:valuekind); FORWARD;
PROCEDURE makereal(VAR fattr: attr); (*CODE TO CONVERT FROM INTEGER TO REAL*)
BEGIN (*MAKEREAL*)
IF fattr.typtr=intptr THEN
BEGIN
load(fattr);
macro3(551B(*HRRZI*),reg1,fattr.reg);
support(convertintegertoreal);
fattr.typtr := realptr
END;
IF gattr.typtr=intptr THEN makereal(gattr)
END (*MAKEREAL*);
PROCEDURE selector(fsys: setofsys; fcp: ctp);
VAR
lattr: attr; lcp: ctp; lsp: stp;
lmin,lmax,indexvalue,indexoffset: integer;
oldic: acrange;
bytes: bitrange;
PROCEDURE sublowbound; (*CODE TO ADJUST A SUBINDEX BY THE LOW BOUND OF ITS TYPE*)
VAR
lattr: attr;
BEGIN (*SLOWBOUND*)
IF lmin > 0 THEN macro3(275B(*SUBI*),regc,lmin)
ELSE
IF lmin < 0 THEN macro3(271B(*ADDI*),regc,-lmin);
IF runtime_check THEN
BEGIN
WITH lattr DO
BEGIN
typtr := intptr; kind := cst; cval.ival := lmax - lmin;
END;
generate_code(317B(*CAMG*),regc,lattr);
macro3(305B(*CAIGE*),regc,0);
support(indexerror)
END
END (*SLOWBOUND*);
BEGIN (*SELECTOR*)
WITH fcp↑, gattr DO
BEGIN
typtr := idtype; kind := varbl; packfg := notpack; vclass := klass;
CASE klass OF
vars:
BEGIN
vlevel := vlev; dplmt := vaddr; indexr := 0;
IF vlev > 1 THEN vrelbyte:= no
ELSE vrelbyte:= right;
IF idtype↑.form = files THEN last_file:= fcp
ELSE last_file:= NIL;
indbit := ord(vkind)
END;
field:
WITH display[disx] DO
IF occur = crec THEN
BEGIN
vlevel := clev; packfg := packf; vrelbyte := crelbyte;
IF packfg = packk THEN
BEGIN
vbyte := fldbyte;
dplmt := cdspl
END
ELSE dplmt := cdspl+fldaddr;
indexr := cindr; indbit:=cindb
END
ELSE error(171);
func:
IF pfdeckind = standard (*STANDARD FUNCTION*) THEN error(502)
ELSE
IF pflev = 0 THEN error(502) (*EXTERNAL FUNCTION*)
ELSE
IF pfkind = formal (*FORMAL FUNCTION*) THEN error(456)
ELSE
BEGIN
vlevel := pflev+1;
vrelbyte := no;
IF NOT activated THEN error(509);
dplmt := 1; (* THE RELATIVE ADDRESS OF THE FUNCTION'S RESULT *)
indexr :=0;
indbit :=0
END
END (*CASE*)
END (*WITH*);
iferrskip(166,selectsys + fsys);
WHILE sy IN selectsys DO
BEGIN
(*[*)
IF sy = lbrack THEN
BEGIN
IF gattr.indbit = 1 THEN get_parameter_address;
oldic := gattr.indexr;
indexoffset := 0 ;
LOOP
lattr := gattr; indexvalue := 0 ;
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
IF typtr↑.form <> arrays THEN
BEGIN
error(307); typtr := NIL
END;
lsp := typtr
END;
insymbol;
expression(fsys + [comma,rbrack],onregc);
IF gattr.kind<>cst THEN load(gattr)
ELSE indexvalue := gattr.cval.ival ;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN error(403);
IF lattr.typtr <> NIL THEN WITH lattr,typtr↑ DO
BEGIN
IF comptypes(inxtype,gattr.typtr) THEN
BEGIN
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
IF gattr.kind = cst THEN
IF (indexvalue < lmin) OR (indexvalue > lmax) THEN error(263)
END
END
ELSE error(457);
typtr := aeltype
END
EXIT IF sy <> comma;
WITH lattr DO
IF typtr<>NIL THEN
IF gattr.kind = cst THEN dplmt := dplmt + ( indexvalue - lmin ) * typtr↑.size
ELSE
BEGIN
sublowbound;
IF typtr↑.size > 1 THEN macro3(221B(*IMULI*),regc,typtr↑.size);
IF oldic = 0 THEN oldic := regc
ELSE
IF oldic > regcmax THEN
BEGIN
macro3(270B(*ADD*),regc,oldic);
oldic := regc
END
ELSE
BEGIN
macro3(270B(*ADD*),oldic,regc) ;
regc := regc - 1
END;
indexr := oldic
END ;
gattr := lattr
END (*LOOP*);
WITH lattr DO
IF typtr <> NIL THEN
BEGIN
IF gattr.kind = cst THEN indexoffset := ( indexvalue - lmin ) * typtr↑.size
ELSE
BEGIN
IF (typtr↑.size > 1) OR runtime_check THEN sublowbound
ELSE indexoffset := -lmin;
IF typtr↑.size > 1 THEN macro3(221B(*IMULI*),regc,typtr↑.size);
indexr := regc
END ;
IF lsp↑.arraypf THEN
BEGIN
bytes := bitmax DIV lsp↑.aeltype↑.bitsize;
IF gattr.kind = cst THEN
BEGIN
bpaddr := indexoffset MOD bytes + lsp↑.arraybpaddr + 1;
indexr := oldic;
indexoffset := indexoffset DIV bytes
END
ELSE
BEGIN
increment_regc;
IF indexr=oldic THEN
BEGIN
increment_regc; indexr := 0
END;
IF lmax <= maxaddr THEN
macro4(571B(*HRREI*),regc,indexr,indexoffset)
ELSE
BEGIN
macro4(200B(*MOVE*),regc,0,indexr);
IF indexoffset <> 0 THEN
macro3(271B(*ADDI*),regc,indexoffset);
END;
increment_regc;
regc := regc-1; indexoffset := 0;
macro3(231B(*IDIVI*),regc,bytes);
macro4r(200B(*MOVE*),regc-1,regc+1,lsp↑.arraybpaddr+1);
bpaddr := regc-1; indexr := regc
END;
packfg := packk
END (*ARRAYPACKFLAG*);
dplmt := dplmt + indexoffset ;
kind := varbl; vclass := vars;
IF ( oldic <> indexr ) AND ( oldic <> 0 ) THEN
BEGIN
IF oldic > regcmax THEN macro3(270B(*ADD*),indexr,oldic)
ELSE
BEGIN
macro3(270B(*ADD*),oldic,indexr);
regc := regc - 1;
indexr := oldic
END
END
END (*WITH.. IF TYPTR <> NIL*) ;
gattr := lattr ;
IF sy = rbrack THEN insymbol
ELSE error(155)
END (*IF SY = LBRACK*)
ELSE
(*.*)
IF sy = period THEN
BEGIN
WITH gattr DO
BEGIN
IF typtr <> NIL THEN
IF typtr↑.form <> records THEN
BEGIN
error(308); typtr := NIL
END;
IF indbit=1 THEN get_parameter_address;
insymbol;
IF sy = ident THEN
BEGIN
IF typtr <> NIL THEN
BEGIN
searchsection(typtr↑.fstfld,lcp);
IF lcp = NIL THEN
BEGIN
error(309); typtr := NIL
END
ELSE WITH lcp↑ DO
BEGIN
typtr := idtype; packfg := packf;
IF packfg = packk THEN
BEGIN
vclass := field; vbyte := fldbyte
END
ELSE dplmt := dplmt + fldaddr
END
END;
insymbol
END (*SY = IDENT*)
ELSE error(209)
END (*WITH GATTR*)
END (*IF SY = PERIOD*)
ELSE
(*↑*)
BEGIN
IF gattr.typtr <> NIL THEN WITH gattr,typtr↑ DO
IF form IN [pointer,files] THEN
BEGIN
IF form = pointer THEN typtr := eltype
ELSE typtr := filtype;
IF typtr <> NIL THEN
BEGIN
loadnoptr := false;
load(gattr); loadnoptr := true;
(* 12. CHECK FOR ZERO OR NIL POINTER *)
IF runtime_check AND (form = pointer) THEN
BEGIN
macro3(302B(*CAIE*),reg,0);
macro3(306B(*CAIN*),reg,377777B);
support(badpointer);
END;
%13 (* 14. EXTERNAL SUPPRESSED FROM PASSGO *)
WITH fcp↑ DO
IF (idtype↑.form = files) AND (vlev = 0) AND external THEN
BEGIN
vaddr:= ic-1; code_reference↑[cix] := externref
END;
(* 14.*) \
indexr := reg; dplmt := 0; indbit:=0; packfg := notpack; kind := varbl;
vrelbyte:= no; vclass := vars
END
END
ELSE error(407);
insymbol
END (*↑*);
iferrskip(166,fsys + selectsys)
END (*WHILE*);
WITH gattr DO
IF typtr<>NIL THEN
IF typtr↑.size = 2 THEN
BEGIN
IF indbit = 1 THEN get_parameter_address;
IF (indexr>regin) AND (indexr<=regcmax) THEN increment_regc
END
END (*SELECTOR*) ;
(* PROFUNCALL[GETFILENAME,variable,GETPUTRESETREWRITE,READREADLN,BREAKCALL,WRITEWRITELN,MESSAGECALL*)
PROCEDURE profuncall(fsys: setofsys; fcp: ctp);
LABEL
666;
VAR
lkey: integer;
lclass: idclass;
lsupport: supports;
tty_message, noload, lfollowerror, no_right_parent, buffer_variable : boolean;
PROCEDURE getfilename(default_name:alfa; followsys: setofsys);
(*PARSES THE FIRST PARAMETER IN CALLS TO FILE-RELATED
PROCEDURES AND FUNCTIONS, OR DEFAULTS IT TO THE
APPROPRIATE STANDARD FILE*)
VAR
lcp : ctp ; lvlev: levrange; default,default_tty : boolean ;
lsy: symbol; lid: alfa;
BEGIN (*GETFILENAME*)
default := true ; default_tty := false; no_right_parent := true;
buffer_variable := false;
IF sy = lparent THEN
BEGIN
no_right_parent := false;
insymbol ;
IF sy = ident THEN
BEGIN
searchid([konst,vars,field,proc,func],lcp);
IF lcp <> NIL THEN
WITH lcp↑,idtype↑ DO
IF idtype <> NIL THEN
BEGIN
IF form = files THEN
BEGIN
IF arrow IN followsys THEN insymbol;
IF sy <> arrow THEN
BEGIN
default := false;
IF
(((lkey IN [2,4,7,8,10,11,17,19,28]) AND (lclass = proc)) OR
((lkey = 11) AND (lclass = func))) AND
(file_form <> text_file) THEN error(366)
END
ELSE buffer_variable := true
END;
IF klass = vars THEN lvlev := vlev
ELSE lvlev := 1
END;
IF (lvlev = 0) AND
(id = 'TTY ') AND
((default_name = 'OUTPUT ') OR (default_name = 'TTYOUTPUT ')) AND
NOT buffer_variable THEN
BEGIN
default := true; default_tty := true;
default_name := 'TTYOUTPUT '
END
END (*SY = IDENT*)
END (*SY = LPARENT*);
IF no_right_parent
AND (sy IN (facbegsys + [addop])) AND NOT ( (lclass=func) AND (lkey IN [10,11]) ) THEN error(156);
ttyread := (NOT default AND (id = 'TTY ')) OR
(default AND (default_name = 'TTY ')) OR ttyread;
outputwrite := outputwrite OR (NOT default AND (id = 'OUTPUT ')) OR
(default AND (default_name = 'OUTPUT ')); (* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
IF default THEN
BEGIN
lid := id; id := default_name;
searchid([vars],lcp);
IF lcp↑.idtype↑.form <> files THEN searchsection(display[0].fname,lcp);
id := lid
END ;
lsy := sy; sy := comma; lfollowerror := followerror;
selector(fsys + [comma,rparent],lcp) ;
sy := lsy; followerror := lfollowerror;
IF noload THEN
WITH gattr DO
BEGIN
IF (indbit <> 0) %13 OR ((lcp↑.vlev = 0) AND external) (* 14.*) \ THEN load_address;
CASE lkey OF
10:
dplmt := dplmt + fileof; (*EOF*)
11:
dplmt := dplmt + fileol; (*EOLN*)
17:
dplmt := dplmt + fillnr (*GETLINENR*)
END
END
ELSE load_address;
IF buffer_variable THEN
BEGIN
searchid([vars],lcp);
selector(fsys + (followsys-[arrow]),lcp)
END;
IF NOT default OR default_tty THEN
BEGIN
IF NOT (arrow IN followsys) THEN insymbol;
IF NOT (sy IN followsys-[arrow]) THEN
error(458)
ELSE
IF sy = comma THEN insymbol
END
END (*GETFILENAME*) ;
PROCEDURE variable(fsys: setofsys);
VAR
lcp: ctp;
BEGIN (*VARIABLE*)
IF sy = ident THEN
BEGIN
searchid([vars,field],lcp); insymbol
END
ELSE
BEGIN
error(209); lcp := uvarptr
END;
selector(fsys,lcp)
END (*VARIABLE*) ;
PROCEDURE getputresetrewrite;
VAR
default : ARRAY [1..4] OF boolean;
i : integer;
lattr: attr;
PROCEDURE getstringaddress(length: integer) ;
BEGIN (*GETSTRINGADDRESS*)
IF sy <> rparent THEN
BEGIN
expression(fsys + [comma],onfixedregc);
WITH gattr DO
IF string(typtr) THEN
WITH typtr↑ DO
IF arraypf AND (size=2) AND (inxtype↑.vmax.ival-inxtype↑.vmin.ival+1 = length) THEN
BEGIN
default[i] := false; load_address
END
ELSE error(458)
ELSE error(458)
END
END (*GETSTRINGADDRESS*);
BEGIN (*GETPUTRESETREWRITE*)
CASE lkey OF
1,2 :
getfilename('INPUT ',[rparent]); (*GET, GETLN*)
3,4 :
getfilename('OUTPUT ',[rparent]); (*PUT, PUTLN*)
5 :
getfilename('INPUT ',[comma,rparent]); (*RESET*)
6 :
getfilename('OUTPUT ',[comma,rparent]) (*REWRITE*)
END;
IF lkey IN [5,6] THEN (*RESET, REWRITE*)
BEGIN
FOR i := 1 TO 4 DO default[i] := true;
i := 1;
getstringaddress(9) (* OF FILENAME *) ;
WHILE (i<3) AND NOT default[1] AND (sy=comma) DO (*PROTECTION, PPN, DEVICE (?)*)
BEGIN
i := i + 1;
insymbol; expression(fsys + [comma],onfixedregc);
IF gattr.typtr <> NIL THEN
IF comptypes(gattr.typtr,intptr) THEN
BEGIN
load(gattr); default[i] := false
END
ELSE error(458)
END;
IF NOT default[3] THEN (*DEVICE*)
BEGIN
i := i+1;
IF sy = comma THEN insymbol;
getstringaddress(6) (* OF DEVICE NAME *)
END;
FOR i := 1 TO 4 DO
IF default[i] THEN
BEGIN
increment_regc;
macro2(400B(*SETZ*),regc)
END
END (*IF LKEY IN [5,6]*) (*RESET, REWRITE*);
CASE lkey OF
1: (*GET*)
BEGIN
lsupport := getfile;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.file_form = text_file THEN lsupport := getcharacter
END;
2: (*GETLN*)
IF comptypes(gattr.typtr,textptr) THEN lsupport := getline
ELSE error(366) ;
3: (*PUT*)
lsupport := putfile ;
4: (*PUTLN*)
IF comptypes(gattr.typtr,textptr) THEN lsupport := putline
ELSE error(366) ;
5: (*RESET*)
lsupport := resetfile ;
6: (*REWRITE*)
lsupport := rewritefile
END ;
support(lsupport);
IF (lkey = 1) AND (gattr.typtr <> NIL) AND runtime_check THEN
IF gattr.typtr↑.filtype <> NIL THEN (*BOUNDARY CHECK FOR FILES OF SUBRANGE*)
WITH gattr.typtr↑.filtype↑ DO
IF (form = subrange) AND (gattr.typtr↑.file_form <> text_file) THEN
BEGIN
increment_regc; macro4(200B(*MOVE*),regc,regc-1,filcmp);
lattr.kind := cst; lattr.typtr := rangetype;
lattr.cval := vmax; generate_code(317B(*CAMG*),regc,lattr);
lattr.cval := vmin; generate_code(315B(*CAMGE*),regc,lattr);
support(inputerror)
END;
END (*GETPUTRESETREWRITE*);
PROCEDURE callsupport;
BEGIN (*CALLSUPPORT*)
IF (lsupport IN [readirange..wrtdset,readpseudostring..writedefpseudostring])
AND ((sy = comma) OR (lkey IN [8,11])) THEN (* 25.*)
BEGIN
IF NOT reg2_saved THEN
BEGIN
reg2_saved := true;
reg2_location := lc;
lc := lc + 1;
IF lc > lcmax THEN lcmax := lc
END;
macro4(202B(*MOVEM*),regc,basis,reg2_location);
support(lsupport);
macro4(200B(*MOVE*),regc,basis,reg2_location)
END
ELSE support(lsupport)
END (*CALLSUPPORT*);
PROCEDURE readreadln; (*READ A LIST OF PARAMETERS FROM A TEXT FILE*)
VAR
boundclass: cstclass;
lattr: attr;
baseform: structform;
%9 SAVREGC: INTEGER; (* 16.*) \
BEGIN (*READREADLN*)
getfilename('INPUT ',[arrow,rparent,comma]);
IF (lkey = 7) OR ((lkey = 8) AND (sy = ident)) OR buffer_variable THEN
LOOP
IF NOT buffer_variable THEN
BEGIN
%9 SAVREGC := REGC; (* 16.*) \
variable(fsys + [comma]);
%9 (* 16. FIX THE MOD BUG (KO)*)
IF (REGC > SAVREGC+1) AND (GATTR.INDEXR > SAVREGC) THEN
BEGIN
MACRO3 (200B(*MOVE*),REGC-1,REGC);
REGC := REGC - 1;
GATTR.INDEXR := GATTR.INDEXR - 1;
END;
(* 16. END OF FIX.*) \
load_address
END;
lsupport := readinteger;
buffer_variable := false;
WITH gattr DO
IF typtr <> NIL THEN
IF typtr↑.form IN [scalar,subrange,power] THEN
BEGIN
IF typtr = charptr THEN typtr := asciiptr;
baseform := typtr↑.form;
IF typtr↑.form = power THEN
BEGIN
typtr := typtr↑.elset;
IF comptypes(typtr,asciiptr) THEN
BEGIN
macro3(551B(*HRRZI*),regc+1,offset);
macro3(551B(*HRRZI*),regc+2,basemax + offset)
END
END;
IF typtr <> NIL THEN
IF typtr↑.form = subrange THEN
BEGIN
IF comptypes(realptr,typtr↑.rangetype) THEN boundclass := reel
ELSE boundclass := int;
lattr.kind := cst;
lattr.cval := typtr↑.vmin; macro2(200B(*MOVE*),regc+1); deposit_constant(boundclass,lattr);
lattr.cval := typtr↑.vmax; macro2(200B(*MOVE*),regc+2); deposit_constant(boundclass,lattr);
typtr := typtr↑.rangetype
END
ELSE
IF typtr↑.scalkind = declared THEN
BEGIN
macro3(551B(*HRRZI*),regc+2,typtr↑.dimension);
macro2(400B(*SETZ*),regc+1)
END;
IF typtr <> NIL THEN
IF typtr↑.scalkind = declared THEN
WITH typtr↑ DO
BEGIN
request := true; macro3r(551B(*HRRZI*),regc+3,vectorchain);
code_reference↑[cix] := constref; vectorchain := ic-1;
lsupport := read_support[declaredform,baseform]
END
ELSE
BEGIN
IF typtr = intptr THEN lsupport := read_support[integerform,baseform]
ELSE
IF comptypes(typtr,asciiptr) THEN lsupport := read_support[charform,baseform]
ELSE
IF typtr = realptr THEN lsupport := read_support[realform,baseform]
ELSE error(458)
END
END
ELSE
IF string(typtr) THEN
BEGIN
IF typtr↑.arraypf THEN lsupport := readpackedstring
ELSE lsupport := readstring;
WITH typtr↑.inxtype↑ DO macro3(551B(*HRRZI*),regc+1,vmax.ival-vmin.ival+1)
END
ELSE
(* 25. ACCEPT TYPE 'STRING' *)
IF typtr = sstringptr THEN
IF stringpack THEN
lsupport := readpseudostring
ELSE
error (321)
ELSE
(* 25.*)
error(169);
regc := regin + 1;
callsupport
EXIT IF sy <> comma;
insymbol
END;
IF lkey = 8 THEN support(getline)
END (*READREADLN*) ;
PROCEDURE breakcall; (*SEND THE OUTPUT BUFFER TO THE FILE*)
BEGIN (*BREAKCALL*)
getfilename('TTYOUTPUT ',[rparent]);
support(putbuffer)
END (*BREAKCALL*);
PROCEDURE writewriteln; (*WRITE INTO A TEXT FILE A LIST OF PARAMETERS*)
VAR
llsp, lsp: stp;
default, realformat, declared_or_set: boolean;
%9 SAVREGC, (* 16.*) \
lsize, lmin, lmax: integer;
BEGIN (*WRITEWRITELN*)
IF NOT tty_message THEN getfilename('OUTPUT ',[rparent,comma,arrow,colon]);
IF (lkey = 10) OR ((lkey = 11) AND (sy IN facbegsys + [addop])) OR buffer_variable THEN
LOOP
IF NOT buffer_variable THEN
BEGIN
%9 SAVREGC := REGC; (* 16. IDIV USES TWO REGISTERS.*) \
expression(fsys + [comma,colon],onfixedregc);
END;
lsp := gattr.typtr;
lsupport := writeinteger;
IF lsp <> NIL THEN
WITH lsp↑ DO
IF form <= power THEN
BEGIN
%9 (* 16. FIX THE MOD BUG.*)
IF (REGC > SAVREGC + 1) AND (GATTR.INDEXR >= REGC) THEN
BEGIN
MACRO3 (200B(*MOVE*),REGC-1, REGC);
REGC := REGC-1;
GATTR.INDEXR := GATTR.INDEXR - 1;
END;
(* 16. END OF FIX.*) \
load(gattr);
declared_or_set := (form = power) OR ((form = scalar) AND (scalkind = declared) AND NOT (lsp = boolptr))
END
ELSE
BEGIN
IF NOT buffer_variable THEN load_address;
declared_or_set := false
END;
buffer_variable := false;
IF sy = colon THEN (*FIELD WIDTH*)
BEGIN
insymbol;
expression(fsys + [comma,colon],onfixedregc);
IF gattr.typtr <> NIL THEN
BEGIN
IF gattr.typtr <> intptr THEN error(458);
IF gattr.kind <> expr THEN
BEGIN
generate_code( 200B (*MOVE*) , regc+1 , gattr ) ;
regc := gattr.reg ;
END ;
END ;
default := false
END
ELSE
BEGIN
default := true;
increment_regc (*RESERVE REGISTER FOR DEFAULT VALUE*)
END ;
IF sy = colon THEN (*SECOND FORMAT MODIFIER*)
BEGIN
insymbol;
IF comptypes(lsp,intptr) THEN
BEGIN
IF (sy = ident) AND ((id='O ') OR (id='H ')) THEN
IF id = 'O ' THEN lsupport := writeoctal
ELSE lsupport := writehexadecimal
ELSE error(262);
insymbol
END
ELSE
BEGIN
expression(fsys + [comma],onfixedregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr <> intptr THEN error(458);
IF lsp <> realptr THEN error(258);
load(gattr);
realformat := false
END
END
ELSE realformat := true;
IF lsp <> intptr THEN
BEGIN
IF comptypes(lsp,asciiptr) THEN lsupport := writecharacter
ELSE
IF lsp = realptr THEN
IF realformat THEN lsupport := writedef1real
ELSE lsupport := writereal
ELSE
IF lsp = boolptr THEN lsupport := writeboolean
ELSE
WITH lsp↑ DO
IF string(lsp) THEN
BEGIN
IF inxtype <> NIL THEN
BEGIN
getbounds(inxtype,lmin,lmax);
lsize := lmax-lmin+1
END
ELSE lsize := 0;
macro3(551B(*HRRZI*),regin+4,lsize);
IF arraypf THEN lsupport := writepackedstring
ELSE lsupport := writestring
END
ELSE
IF (lsp <> NIL) AND declared_or_set THEN
BEGIN
IF form = power THEN
BEGIN
IF elset <> NIL THEN
IF elset↑.form = subrange THEN llsp := elset↑.rangetype
ELSE llsp := elset
END
ELSE llsp := lsp;
IF llsp <> NIL THEN
IF llsp↑.scalkind = declared THEN
WITH llsp↑ DO
BEGIN
IF default THEN macro3(515B(*HRLZI*),regc,dimension)
ELSE macro3(505B(*HRLI*),regc,dimension);
macro3r(551B(*HRRZI*),regc+1,vectorchain);
vectorchain := ic-1; request := true;
code_reference↑[cix] := constref; lsupport := write_support[declaredform,lsp↑.form]
END
ELSE
BEGIN
IF default THEN macro2(400B(*SETZ*),regc);
IF llsp = intptr THEN lsupport := write_support[integerform,form]
ELSE
IF comptypes(llsp,asciiptr) THEN lsupport := write_support[charform,form]
ELSE error(458)
END
END
ELSE
(* 25. ACCEPT TYPE 'STRING'*)
IF lsp = sstringptr THEN
IF stringpack THEN
lsupport := writepseudostring
ELSE
error(321)
ELSE
(* 25.*)
error(458)
END;
IF default AND NOT declared_or_set THEN lsupport := succ( lsupport );
regc :=regin + 1;
callsupport
EXIT IF sy <> comma;
insymbol
END (* LOOP *);
IF lkey = 11 THEN support(putline)
END (*WRITEWRITELN*) ;
PROCEDURE messagecall;
(* MESSAGE(<ARGUMENT LIST>)
IS EQUIVALENT TO
WRITELN(TTY);
WRITELN(TTY,<ARGUMENT LIST>);
BREAK(TTY); *)
BEGIN (*MESSAGECALL*)
increment_regc;
macro3r(551B(*HRRZI*),regc,stdfileptr[4]↑.vaddr);
%13 (* 14.*)
IF external THEN stdfileptr[4]↑.vaddr := ic - 1;
(* 14.*) \
support(putline);
lkey := 11; tty_message := true;
writewriteln;
tty_message := false;
support(putbuffer)
END (*MESSAGECALL*);
(* PACKUNPACK, NEWDISPOSE, FIRSTLAST, LOWERUPPERBOUND *)
PROCEDURE packunpack;
(******************************************************************************
*
* PACK(A,I,Z<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO Z[J1+K] := A[I+K]
*
* UNPACK(Z,A,I<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO A[I+K] := Z[J1+K]
*
* A IS AN ARRAY OF A SCALAR-TYPE,
* Z IS A PACKED ARRAY OF THIS TYPE (SO THE BITSIZE MUST BE <= 18),
* I IS THE ABSOLUTE START-INDEX IN A,
* J IS THE ABSOLUTE START-INDEX IN Z,
* L IS THE NUMBER OF ELEMENTS TO BE PACKED/UNPACKED,
* J1 IS J (DEFAULT: LOWERBOUND(Z)),
* L1 IS L (DEFAULT: MIN(UPPERBOUND(Z)-J1,UPPERBOUND(A)-I)+1),
* K IS NOT DENOTED ELSEWHERE IN THE PROGRAM.
*
******************************************************************************)
VAR
a,i,z,j,l: attr; lregc: acrange;
length, astart, zstart, amax, amin, zmax, zmin, packfactor: integer;
default_length: boolean;
PROCEDURE adjust( VAR fattr: attr; fbound: integer);
BEGIN (*ADJUST*)
load(fattr);
IF fbound < 0 THEN macro3(271B(*ADDI*),fattr.reg,-fbound)
ELSE
IF fbound > 0 THEN macro3(275B(*SUBI*),fattr.reg,fbound);
IF runtime_check THEN
BEGIN
macro2(305B(*CAIGE*),fattr.reg);
support(indexerror)
END
END (*ADJUST*);
PROCEDURE getoffset( VAR fattr: attr; fsys: setofsys; comptyptr: stp);
BEGIN (*GETOFFSET*)
expression(fsys,onregc); fattr := gattr;
IF NOT errorflag THEN
WITH fattr DO
IF typtr <> NIL THEN
IF NOT comptypes(typtr,comptyptr) THEN error(458);
IF (sy=comma) AND (comma IN fsys) THEN insymbol
ELSE
IF (sy <> rparent) OR NOT (rparent IN fsys) THEN error(458)
END (*GETOFFSET*);
PROCEDURE getvar( VAR fattr: attr; fsys: setofsys; comptyptr: stp);
BEGIN (*GETVAR*)
variable(fsys); load_address; fattr := gattr;
IF NOT errorflag THEN
WITH fattr DO
IF typtr <> NIL THEN
WITH typtr↑ DO
IF form = arrays THEN
BEGIN
IF comptyptr = NIL THEN
IF lkey = 12 THEN
BEGIN
IF arraypf THEN error(458)
END
ELSE
BEGIN
IF NOT arraypf THEN error(458)
END
ELSE
IF NOT ((arraypf <> comptyptr↑.arraypf) AND
comptypes(aeltype,comptyptr↑.aeltype) AND
comptypes(inxtype,comptyptr↑.inxtype)) THEN error(458);
kind := expr;
IF arraypf THEN
BEGIN
reg := reg1; regc := regc-1;
code_array↑.instruction[cix].ac := reg1
END
ELSE reg := indexr
END
ELSE error(458);
IF (sy = comma) AND (comma IN fsys) THEN insymbol
ELSE
IF (sy <> rparent) OR NOT (rparent IN fsys) THEN error(458)
END (*GETVAR*);
BEGIN (* PACKUNPACK *)
lregc := regc; default_length := true;
IF lkey = 12 THEN
BEGIN
getvar(a,[comma],NIL);
IF a.typtr <> NIL THEN getoffset(i,[comma],a.typtr↑.inxtype)
ELSE getoffset(i,[comma],NIL);
getvar(z,[comma,rparent],a.typtr)
END
ELSE
BEGIN
getvar(z,[comma],NIL);
getvar(a,[comma],z.typtr);
IF a.typtr <> NIL THEN getoffset(i,[comma,rparent],a.typtr↑.inxtype)
ELSE getoffset(i,[comma,rparent],NIL)
END;
IF NOT errorflag THEN
BEGIN
getbounds(a.typtr↑.inxtype,amin,amax); amax := amax-amin;
getbounds(z.typtr↑.inxtype,zmin,zmax); zmax := zmax-zmin;
END;
WITH j DO
BEGIN
kind := cst; cval.ival := zmin
END;
WITH l DO
BEGIN
kind := cst; cval.ival := 0
END;
IF sy <> rparent THEN
BEGIN
IF z.typtr <> NIL THEN getoffset(j,[comma,rparent],z.typtr↑.inxtype)
ELSE getoffset(j,[comma,rparent],NIL);
IF sy <> rparent THEN
BEGIN
default_length := false;
getoffset(l,[rparent],intptr)
END
END;
IF NOT errorflag THEN
BEGIN
astart := 0; packfactor := bitmax DIV z.typtr↑.aeltype↑.bitsize;
IF (i.kind = cst) AND (j.kind = cst) AND (l.kind = cst) THEN
BEGIN
astart := i.cval.ival - amin;
zstart := j.cval.ival - zmin;
IF (astart >= 0) AND (zstart >= 0) THEN
BEGIN
length := min(zmax-zstart, amax-astart) + 1;
IF length >= 0 THEN
BEGIN
IF NOT default_length THEN
IF (l.cval.ival >= 0) AND (l.cval.ival <= length) THEN length := l.cval.ival
ELSE error(263);
macro3(505B(*HRLI*),a.reg,-length);
IF (zstart DIV packfactor) <> 0 THEN
macro3(271B(*ADDI*),z.reg,zstart DIV packfactor);
macro3r(200B(*MOVE*),regc+1,z.typtr↑.arraybpaddr+(zstart MOD packfactor))
END
ELSE error(263)
END
ELSE error(263)
END
ELSE (* KIND <> CST *)
BEGIN
adjust(i,amin);
macro3(270B(*ADD*),a.reg,i.reg);
adjust(j,zmin);
IF runtime_check OR default_length THEN
BEGIN
macro3(275B(*SUBI*),i.reg,amax);
macro3(200B(*MOVE*),regc+1,j.reg);
macro3(275B(*SUBI*),regc+1,zmax);
macro3(315B(*CAMGE*),i.reg,regc+1);
macro3(200B(*MOVE*),i.reg,regc+1);
IF runtime_check THEN
BEGIN
macro2(303B(*CAILE*),i.reg);
support(indexerror)
END;
IF default_length THEN macro4(505B(*HRLI*),a.reg,i.reg,-1)
END;
IF NOT default_length THEN
IF runtime_check OR (l.kind <> cst) THEN
BEGIN
generate_code(210B(*MOVN*),regc+1,l);
IF runtime_check THEN
BEGIN
macro2(307B(*CAIG*),l.reg);
macro3(315B(*CAMGE*),l.reg,i.reg);
support(indexerror)
END;
macro3(504B(*HRL*),a.reg,l.reg)
END
ELSE macro3(505B(*HRLI*),a.reg,-l.cval.ival);
macro3(231B(*IDIVI*),j.reg,packfactor);
macro3(270B(*ADD*),z.reg,j.reg);
macro4r(200B(*MOVE*),regc+1,j.reg+1,z.typtr↑.arraybpaddr)
END;
IF lkey = 12 THEN
BEGIN
macro4(200B(*MOVE*),reg0,a.reg,astart);
macro3(136B(*IDPB*),reg0,regc+1)
END
ELSE
BEGIN
macro3(134B(*ILDB*),reg0,regc+1);
macro4(202B(*MOVEM*),reg0,a.reg,astart)
END;
macro3r(253B(*AOBJN*),a.reg,ic-2)
END (* IF NOT ERRORFLAG *)
END (* PACKUNPACK *);
PROCEDURE newdispose;
(* "NEW" ALLOCATES STORAGE FOR A DYNAMIC VARIABLE
(F.E. A RECORD VARIANT) IN THE HEAP.
"DISPOSE" DE-ALLOCATES THE STORAGE OCCUPIED BY
SUCH A VARIABLE AND IN THIS IMPLEMENTATION IT
DE-ALLOCATES THE STORAGE OF ALL VARIABLES ALLOCATED
LATER THAN THE SPECIFIED ONE TOO.
THIS IS DUE TO THE STACK-LIKE HEAP MANAGEMENT
WITH ONLY "NEWREG" POINTING TO THE LAST ALLOCATED
WORD OF CORE*)
LABEL
777;
VAR
lsp,lsp1: stp; varts,lmin,lmax: integer;
lnlk : nlk;
lengthreg: acrange;
lsize,lsz: addrrange; lval: valu;
lattrc, lattr: attr; i,tagfc: integer;
tagfsav: ARRAY[0..tagfmax] OF RECORD
tagfval: integer;
tagtype: tagfwithid..tagfwithoutid;
CASE tpackkind: packkind OF
notpack,
hwordl,
hwordr: (tagfaddr: addrrange);
packk: (tagfbyte: bpointer)
END;
BEGIN (*NEWDISPOSE*)
increment_regc; variable(fsys + [comma,colon]);
IF lkey = 24 (*DISPOSE*) THEN
BEGIN
generate_code(200B(*MOVE*),reg0,gattr);
lengthreg := reg1
END
ELSE lengthreg := regin + 1;
lsp := NIL; varts := 0; lsize := 0; tagfc := -1;
lattr := gattr;
IF gattr.typtr <> NIL THEN WITH gattr.typtr↑ DO
IF form = pointer THEN
BEGIN
IF eltype <> NIL THEN
BEGIN
lsize := eltype↑.size;
IF eltype↑.form = records THEN lsp := eltype↑.recvar
ELSE
IF eltype↑.form = arrays THEN lsp := eltype
END
END
ELSE error(458);
WHILE sy = comma DO
BEGIN
insymbol; constant(fsys + [comma,colon],lsp1,lval);
varts := varts + 1;
IF lsp <> NIL THEN
IF NOT (string(lsp) OR (lsp1 = realptr)) THEN
BEGIN
tagfc := tagfc + 1;
IF tagfc <= tagfmax THEN
IF lsp↑.form = tagfwithid THEN
BEGIN
IF lsp↑.tagfieldp <> NIL THEN
IF comptypes(lsp↑.tagfieldp↑.idtype,lsp1) THEN
WITH tagfsav[tagfc], lsp↑.tagfieldp↑ DO
BEGIN
tagfval := lval.ival;
tagtype := tagfwithid; tpackkind := packf;
IF tpackkind = packk THEN tagfbyte := fldbyte
ELSE tagfaddr := fldaddr
END
ELSE error(458)
END
ELSE
IF lsp↑.form = tagfwithoutid THEN
IF comptypes(lsp↑.tagfieldtype,lsp1) THEN tagfsav[tagfc].tagtype := tagfwithoutid
ELSE error(458)
ELSE error(358)
ELSE
BEGIN
error(409); tagfc := tagfmax
END;
lsp1 := lsp↑.fstvar;
WHILE lsp1 <> NIL DO
WITH lsp1↑ DO
IF varval.ival = lval.ival THEN
BEGIN
lsize := size; lsp := subvar; GOTO 777
END
ELSE lsp1 := nxtvar;
lsize := lsp↑.size; lsp := NIL;
777:
END
ELSE error(460)
ELSE error(408)
END (*WHILE*) ;
IF sy = colon THEN
BEGIN
insymbol;
expression(fsys,onregc);
IF lsp = NIL THEN error(408)
ELSE
IF lsp↑.form <> arrays THEN error(259)
ELSE
BEGIN
IF NOT comptypes(gattr.typtr,lsp↑.inxtype) THEN error(458);
lsz := 1; lmin := 1;
IF lsp↑.inxtype <> NIL THEN getbounds(lsp↑.inxtype,lmin,lmax);
IF lsp↑.aeltype <> NIL THEN lsz := lsp↑.aeltype↑.size;
load(gattr);
IF lsz <> 1 THEN macro3(221B(*IMULI*),regc,lsz);
IF lsp↑.arraypf THEN
BEGIN
macro3(271B(*ADDI*),regc,lsp↑.aeltype↑.bitsize-1);
increment_regc; regc := regc - 1;
(*FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO*)
macro3(231B(*IDIVI*),regc,bitmax DIV lsp↑.aeltype↑.bitsize);
lsz := lsize - lsp↑.size + 1
END
ELSE lsz := lsize - lsp↑.size - lsz*(lmin - 1);
macro4(551B(*HRRZI*),lengthreg,regc,lsz)
END
END
ELSE macro3(551B(*HRRZI*),lengthreg,lsize);
IF lkey = 14 THEN
BEGIN
IF debug_switch THEN
BEGIN
macro3(540B(* HRR *),reg0,newreg);
IF lattr.typtr <> NIL THEN
IF lattr.typtr↑.eltype <> NIL THEN
BEGIN
macro3r(505B(* HRLI *), reg0,0);
code_reference↑[cix] := debugref;
new(lnlk);
WITH lnlk↑ DO
BEGIN
refadr := ic - 1;
reftype := lattr.typtr↑.eltype;
next := globnewlink;
globnewlink := lnlk;
END;
END
END;
support(allocate);
IF debug_switch THEN
BEGIN
macro3(360B(*SOJ*),newreg,0);
macro4(202B(*MOVEM*),reg0,newreg,0)
END;
regc := regin+1;
FOR i := 0 TO tagfc DO
WITH tagfsav[i] DO
BEGIN
IF tagtype = tagfwithid THEN
BEGIN
macro3(551B(*HRRZI*),reg0,tagfval);
CASE tpackkind OF
notpack:
macro4(202B(*MOVEM*),reg0,regc,tagfaddr);
hwordr:
macro4(542B(*HRRM*),reg0,regc,tagfaddr);
hwordl:
macro4(506B(*HRLM*),reg0,regc,tagfaddr);
packk :
BEGIN
WITH lattrc, cval, byte DO
BEGIN
kind := cst;
cval.byte := tagfbyte;
ireg := regc
END;
macro2(137B(*DPB*),reg0); deposit_constant(bptr,lattrc)
END
END(*CASE*)
END
END;
store(regc,lattr)
END
ELSE support(free)
END (*NEWDISPOSE*) ;
PROCEDURE firstlast;
(* RETURN LOWER- OR UPPERBOUND OF "STANDARD SCALARS",
"DECLARED SCALARS" AND THEIR "SUBRANGES"*)
VAR
lmin, lmax: integer;
BEGIN (*FIRSTLAST*)
variable(fsys + [rparent]);
IF gattr.typtr <> NIL THEN
WITH gattr DO
IF NOT comptypes(realptr,typtr) THEN
BEGIN
getbounds(typtr,lmin,lmax);
kind := cst;
IF lkey = 21 THEN cval.ival := lmin
ELSE cval.ival := lmax;
IF typtr↑.form = subrange THEN typtr := typtr↑.rangetype
END
ELSE error(459)
END (*FIRSTLAST*);
PROCEDURE lowerupperbound;
(* RETURN LOWER- OR UPPERBOUND OF
ARRAY INDEX TYPE*)
VAR
lmin, lmax: integer;
BEGIN (*LOWERUPPERBOUND*)
variable(fsys + [rparent]);
IF gattr.typtr <> NIL THEN
WITH gattr DO
IF (typtr↑.form = arrays) AND (typtr↑.inxtype <> NIL) THEN
BEGIN
getbounds(typtr↑.inxtype,lmin,lmax);
kind := cst;
IF lkey = 15 THEN cval.ival := lmin
ELSE cval.ival := lmax;
IF typtr↑.inxtype↑.form = subrange THEN typtr := typtr↑.inxtype↑.rangetype
ELSE typtr := typtr↑.inxtype
END
ELSE error(459)
END (*LOWERUPPERBOUND*);
(*MINMAX,GETLINENRCALL,PAGECALL,DATECALL,TIMECALL,CLOCKCALL,CARDCALL*)
PROCEDURE minmax;
(* THIS PROCEDURE GENERATES CODE FOR THE MIN/MAX FUNCTION.
THE MAXIMUM NUMBER OF SCALAR-TYPE EXPRESSIONS -EXCEPT REAL-
IS 72 *)
CONST
topp_offset = 2;
max_expr = 72;
VAR
i, j: integer;
lregc: acrange;
insert_size: coderange;
linstr: instrange;
first_expression, conversion: boolean;
selector: scalarform;
argument: PACKED ARRAY[1..max_expr] OF scalarform;
BEGIN (*MINMAX*)
first_expression := true;
conversion := false;
i := 1;
lregc := regc;
macro4(307B(*CAIG*),newreg,topp,0); insert_size := cix;
support(stackoverflow);
macro3(271b(*addi*),topp,topp_offset+1);
LOOP
expression(fsys + [comma,rparent], onfixedregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN error(458)
ELSE
WITH gattr DO
BEGIN
load(gattr);
IF typtr = intptr THEN argument[i] := integerform
ELSE
IF typtr = realptr THEN argument[i] := realform
ELSE
IF comptypes(typtr,asciiptr) THEN argument[i] := charform
ELSE
IF (typtr↑.scalkind = declared) AND (typtr <> boolptr) THEN argument[i] := declaredform
ELSE error(458);
macro4(202B(*MOVEM*),reg,topp,0);
macro3(350b(*aos*),0,topp);
IF first_expression THEN
BEGIN
first_expression := false; selector := argument[i]
END
ELSE
IF selector <> argument[i] THEN
IF [selector,argument[i]] <= [integerform,realform] THEN
BEGIN
conversion := true; selector := realform
END
ELSE error(458)
END
EXIT IF sy <> comma;
i := i + 1;
IF i > max_expr THEN
BEGIN
error(458); i := 1
END;
insymbol;
regc := lregc
END;
IF i <= 1 THEN (*ONE ONLY PARAMETER*)
error(554)
ELSE
IF NOT errorflag THEN
BEGIN
insert_address(no, insert_size, topp_offset + i+1);
macro3(275b(*subi*),topp,topp_offset+i+1);
IF conversion THEN
FOR j := 1 TO i DO
IF argument[j] = integerform THEN
BEGIN
macro4(551B(*HRRZI*),reg1,topp,topp_offset + j);
support(convertintegertoreal)
END;
increment_regc;
macro4(541B(*HRRI*),regc,topp,topp_offset + 2);
macro3(505B(*HRLI*),regc,-(i - 1));
macro4(200B(*MOVE*),gattr.reg,topp,topp_offset + 1);
IF lkey = 20 THEN linstr := 315B(*CAMGE*)
ELSE linstr := 313B(*CAMLE*);
macro4(linstr,gattr.reg,regc,0);
macro4(200B(*MOVE*),gattr.reg,regc,0);
macro3r(253B(*AOBJN*),regc,ic - 2);
IF conversion THEN gattr.typtr := realptr
END
END (*MINMAX*);
PROCEDURE getlinenrcall; (*ASSIGN THE CURRENT LINE NUMBER FROM A TEXT FILE
TO A PACKC5 PARAMETER*)
BEGIN (*GETLINENRCALL*)
getfilename('INPUT ',[comma]);
load(gattr);
variable(fsys);
IF comptypes(gattr.typtr,packc5ptr) THEN store(regc,gattr)
ELSE error(458)
END (*GETLINENRCALL*);
PROCEDURE pagecall; (*WRITE A PAGEMARK INTO A TEXT FILE*)
BEGIN (*PAGECALL*)
getfilename('OUTPUT ',[rparent]);
support(putpage)
END (*PAGECALL*);
PROCEDURE datecall; (* ASSIGN DATE IN STANDARD DD-MMM-YY FORMAT TO ALFA PARAMETER *)
BEGIN (*DATECALL*)
variable(fsys);
IF comptypes(alfaptr,gattr.typtr) THEN load_address
ELSE error(458);
support(asciidate)
END (*DATECALL*);
PROCEDURE timecall; (* ASSIGN TIME IN STANDARD HH:MM:SS FORMAT TO ALFA PARAMETER *)
BEGIN (*TIMECALL*)
variable(fsys);
IF comptypes(alfaptr,gattr.typtr) THEN load_address
ELSE error(458);
support(asciitime)
END (*TIMECALL*);
PROCEDURE clockcall; (* RETURN THE ELAPSED CPU-TIME IN MILLISECONDS *)
BEGIN (*CLOCKCALL*)
WITH gattr DO
BEGIN
increment_regc; typtr := intptr; reg := regc; kind := expr;
macro3(047B,regc,30B(*PJOB-UUO*));
macro3(047B,regc,27B(*RUNTIM-UUO*))
END
END (*CLOCKCALL*);
PROCEDURE cardcall; (* RETURN THE CARDINAL NUMBER OF A SET *)
VAR
loop_around: addrrange;
BEGIN (*CARDCALL*)
WITH gattr DO
BEGIN
IF typtr <> NIL THEN
IF typtr↑.form <> power THEN error(459)
ELSE
BEGIN
increment_regc; increment_regc;
macro3(551B(*HRRZI*),regc,72);
macro2(400B(*SETZ*),regc-1);
loop_around := ic;
macro2(305B(*CAIGE*),gattr.reg - 1);
macro2(340B(*AOJ*),regc-1);
macro3(246B(*LSHC*),gattr.reg - 1,1);
macro3r(367B(*SOJG*),regc,loop_around);
regc := regc - 1;
kind := expr; reg := regc; typtr := intptr
END
END
END (*CARDCALL*);
(*ABSCALL,REALTIMECALL,SQRCALL,ODDCALL,ORDCALL,CHRCALL,PREDSUCC,EOFEOLN,PROTECTION,CALLTOCALL[GETSTRINGADDRESS],HALTCALL*)
PROCEDURE abscall; (*RETURN THE ABSOLUTE VALUE OF AN INTEGER OR REAL EXPRESSION*)
BEGIN (*ABSCALL*)
WITH gattr DO
IF (typtr = intptr) OR (typtr = realptr) THEN
IF kind=expr THEN macro3(214B(*MOVM*),reg,reg)
ELSE
BEGIN
increment_regc;
generate_code(214B(*MOVM*),regc,gattr)
END
ELSE
BEGIN
error(459); typtr:= intptr
END
END (*ABSCALL*) ;
PROCEDURE realtimecall; (* RETURN THE DAY-TIME IN MILLISECONDS *)
BEGIN (*REALTIMECALL*)
WITH gattr DO
BEGIN
increment_regc; typtr := intptr; reg := regc; kind := expr;
macro3(047B,regc,23B(*MSTIME-UUO*))
END
END (*REALTIMECALL*);
PROCEDURE sqrcall; (*RETURN THE SQUARE OF AN INTEGER OR REAL EXPRESSION*)
BEGIN (*SQRCALL*)
WITH gattr DO
IF typtr = intptr THEN macro3(220B(*IMUL*),reg,reg)
ELSE
IF typtr = realptr THEN macro3(164B(*FMPR*),reg,reg)
ELSE
BEGIN
error(459); typtr := intptr
END
END (*SQRCALL*) ;
PROCEDURE oddcall; (*RETURN TRUE IF THE INTEGER PARAMETER IS ODD*)
BEGIN (*ODDCALL*)
WITH gattr DO
BEGIN
IF typtr <> intptr THEN error(459);
macro3(405B(*ANDI*),reg,1);
typtr := boolptr
END
END (*ODDCALL*) ;
PROCEDURE ordcall; (*RETURN THE INTEGER (INTERNAL) VALUE OF A SCALAR*)
BEGIN (*ORDCALL*)
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form >= power THEN error(459);
gattr.typtr := intptr
END (*ORDCALL*) ;
PROCEDURE chrcall; (*RETURN THE CHARACTER WHOSE ASCII CODE IS THE PARAMETER*)
BEGIN (*CHR*)
IF gattr.typtr <> intptr THEN error(459);
gattr.typtr := charptr
END (*CHR*) ;
PROCEDURE predsucc;
VAR
lsp:stp;
pmin,pmax: integer;
BEGIN (*PREDSUCC*)
IF gattr.typtr <> NIL THEN
IF (gattr.typtr↑.form>subrange) OR (gattr.typtr=realptr) THEN error(459)
ELSE
BEGIN
lsp := gattr.typtr;
IF (lsp↑.form = subrange) THEN lsp := lsp↑.rangetype;
IF runtime_check AND (lsp <> intptr) THEN
BEGIN
IF lkey=8 THEN macro3r(365B(*SOJGE*),regc,ic+2)
ELSE
BEGIN
macro2(340B(*AOJ*),regc);
getbounds(lsp,pmin,pmax);
macro3(303B(*CAILE*),regc,pmax)
END;
support(errorinassignment)
END (* RUNTIME_CHECK *)
ELSE
IF lkey = 8 THEN macro2(360B(*SOJ*),regc)
ELSE macro2(340B(*AOJ*),regc)
END
END (*PREDSUCC*) ;
PROCEDURE eofeoln; (*RETURN TEH VALUE OF THE EOLN OR EOF FLAG OF THE FILE*)
BEGIN (*EOFEOLN*)
getfilename('INPUT ',[rparent]);
WITH gattr DO
BEGIN
increment_regc; generate_code(332B(*SKIPE*),regc,gattr);
macro3(551B(*HRRZI*),regc,1);
typtr := boolptr;
END
END (*EOFEOLN*) ;
PROCEDURE protection;
(* THIS PROCEDURE IS USED BY "PASDDT" TO TEST
IF A PROGRAM'S HIGH-SEGMENT IS SHARED
(WRITE-PROTECTED). PROGRAMS WHICH ARE
TO BE "DEBUGGED" MUST NOT BE SHARABLE.
FOR DETAILS SEE DECSYSTEM-10 "MONITOR-CALLS"
MANUAL, 3.2.4 *)
BEGIN (*PROTECTION*)
expression(fsys, onregc);
IF gattr.typtr = boolptr THEN
BEGIN
load(gattr);
macro3(047B,gattr.reg,36B(*SETUWP-UUO*));
macro3(254B(*HALT*),4,0)
END
ELSE error(458)
END (*PROTECTION*);
PROCEDURE calltocall;
(* THE STANDARD PROCEDURE
CALL(<FILENAME>[,<DEVICE>[,<PROJECT-PROGRAMMER>[,<CORE-ASSIGNMENT]]])
ALLOWS TO EXIT FROM ONE PROGRAM AND EXECUTE ANOTHER *)
VAR
i:integer;
default:ARRAY[2..4] OF boolean;
PROCEDURE getstringaddress(flength: integer);
BEGIN (*GETSTRINGADDRESS*)
expression(fsys + [comma],onfixedregc);
WITH gattr DO
IF string(typtr) THEN
WITH typtr↑ DO
IF arraypf AND (size = 2) AND ((inxtype↑.vmax.ival-inxtype↑.vmin.ival+1) = flength) THEN load_address
ELSE error(458)
ELSE error(458)
END (*GETSTRINGADDRESS*);
BEGIN (* CALLTOCALL *)
%13 (* 14. EXTERNAL SUPPRESSED FROM PASSGO *)
IF NOT external THEN
BEGIN
(* 14.*) \
close_files;
getstringaddress(9);
FOR i := 2 TO 4 DO default[i] := true;
IF sy = comma THEN
BEGIN
insymbol; getstringaddress(6); default[2] := false;
IF sy = comma THEN
BEGIN
insymbol; expression(fsys + [comma],onfixedregc);
IF gattr.typtr = intptr THEN
BEGIN
default[3] := false; load(gattr)
END
ELSE error(458);
IF sy = comma THEN
BEGIN
insymbol; expression(fsys,onfixedregc);
IF gattr.typtr = intptr THEN
BEGIN
default[4] := false; load(gattr)
END
ELSE error(458)
END
END
END;
FOR i := 2 TO 4 DO
IF default[i] THEN
BEGIN
increment_regc; macro2(400B(*SETZ*),regc)
END;
support(runprogram);
%13 (* 14. EXTERNAL SUPPRESSED FROM PASSGO.*)
END
ELSE error(353)
(* 14.*) \
END (* CALLTOCALL *);
PROCEDURE haltcall; (*THIS PROCEDURE CALLS "PASDDT" IF IT IS LOADED, OTHERWISE IT
EXECUTES A "HALT" INSTRUCTION *)
BEGIN (*HALTCALL*)
macro3(332B(*SKIPE*),reg1,jbddt);
macro4(265B(*JSP*),reg0,reg1,-2);
macro2(254B(*HALT*),4)
END (*HALTCALL*);
(*CALL_NON_STANDARD[COMPPARAM,CHECKSSTRINGCALLS,CHARCONSTANT,saveexpr] ]PROFUNCALL*)
PROCEDURE call_non_standard;
VAR
lst,nxt,lnxt,lcp,lcp1: ctp;
lsp: stp;
lkind: idkind; pascalcall:boolean;
save_count,p,i,number_of_parameters: integer;
topp_offset,offset,start_of_parameterlist,actual_parameter,first_parameter,llc: addrrange;
lregc: acrange;
lalfa: alfa;
oldsstringstart,
oldparsingparameters: boolean;
FUNCTION compparam(fcp1,fcp2 : ctp):boolean;
VAR
ok:boolean;
BEGIN (*COMPPARAM*)
ok:=true;
WHILE ok AND (fcp1<>NIL) AND (fcp2<>NIL) DO WITH fcp1↑ DO
BEGIN
IF comptypes(idtype,fcp2↑.idtype) THEN
IF klass=fcp2↑.klass THEN
IF klass=vars THEN
BEGIN
IF vkind<>fcp2↑.vkind THEN
BEGIN
error(370); ok:=false
END
END
ELSE ok:=compparam(fparam,fcp2↑.fparam)
ELSE
BEGIN
error(370); ok:=false
END
ELSE
BEGIN
error(370); ok:=false
END;
fcp1:=next; fcp2:=fcp2↑.next
END;
IF fcp1<>fcp2 THEN
BEGIN
error(554); compparam:=false
END
ELSE compparam:=ok
END(*COMPPARAM*);
(* 25. PASS THE STRING LENGTHS FOR STRING PROCEDURE CALLS.*)
PROCEDURE checksstringcalls;
VAR
i, j: integer;
BEGIN (*CHECKSSTRINGCALLS*);
IF sstringlength <> NIL THEN
IF lst <> NIL THEN
WITH sstringlength↑ DO
BEGIN
j := 1;
FOR i := 1 TO count DO
BEGIN
increment_regc;
macro3(551B(*HRRZI*),regc,value[i]);
IF regc > fcp↑.highest_register THEN
BEGIN
macro4(552B(*HRRZM*),regc,topp,lst↑.vaddr + lst↑.idtype↑.size + j);
regc := fcp↑.highest_register;
j := j + 1;
END;
END;
sstringlength := next;
END;
END (*CHECKSSTRINGCALLS*) (* 25.*);
(* 25. PUT CHARACTER CONSTANTS IN A PLACE IN MEMORY.*)
PROCEDURE charconstant (fchar: char);
VAR
lcsp: csp;
BEGIN (*CHARCONSTANT*)
new(lcsp,strg);
WITH lcsp↑ DO
BEGIN
slgth := 1; sval[1] := fchar;
END;
WITH gattr DO
BEGIN
typtr := packc1ptr;
kind := cst;
cval.valp := lcsp;
END
END (*CHARCONSTANT*);
(* 25. put string expressions in memory, to be able to address them.*)
procedure saveexpr;
var
lattr: attr;
begin (*saveexpr*)
with lattr do
begin
typtr := gattr.typtr;
kind := varbl;
vlevel := level;
dplmt := lc;
indexr := basis;
packfg := notpack;
indbit := 0;
vrelbyte := no;
lc := lc + typtr↑.size;
end;
if lcmax < lc then
lcmax := lc;
store(gattr.reg,lattr);
gattr := lattr;
regc := regc-1;
end (*saveexpr*);
BEGIN (* CALL_NON_STANDARD *)
number_of_parameters:= 0; topp_offset := 0; start_of_parameterlist := 0;
actual_parameter := 0; lalfa := ' '; lst := NIL; (* 25.*)
llc := lc ;
pctp := fcp; (* 25.*)
WITH fcp↑ DO
BEGIN
lkind := pfkind;
IF lkind=actual THEN
BEGIN
nxt:=next;
%13 (* 17.*)
IF externdecl THEN library[language].called:=true;
(* 17.*) \
pascalcall:=language=pascalsy
END
ELSE (* LKIND <> ACTUAL *)
BEGIN
nxt:=fparam;
pascalcall:=true
END;
lnxt:=nxt;
IF klass = func THEN first_parameter := 2
ELSE first_parameter := 1;
save_count := regc - regin;
IF save_count > 0 THEN
BEGIN
lc := lc + save_count ;
IF lc > lcmax THEN lcmax := lc ;
IF save_count > 3 THEN
BEGIN
macro3(515B(*HRLZI*),reg1,2);
macro4(541B(*HRRI*),reg1,basis,llc);
macro4(251B(*BLT*),reg1,basis,llc+save_count-1)
END
ELSE FOR i := 1 TO save_count DO macro4(202B(*MOVEM*),regin+i,basis,llc+i-1)
END;
lregc:= regc;
IF lkind=actual THEN
IF language <> pascalsy THEN regc:= highest_register
ELSE regc:= regin
ELSE regc:=regin
END;
IF sy = lparent THEN
BEGIN (* PARAMETERS.*)
oldparsingparameters := parsingparameters;
oldsstringstart := sstringstart;
parsingparameters := true; (* 25. *)
sstringstart := true; (* 25. *)
REPEAT
recall := false; (* 25.*)
insymbol;
IF nxt=NIL THEN error(554)
ELSE
IF nxt↑.klass IN [proc,func] THEN
IF sy<>ident THEN error(209)
ELSE
BEGIN
searchid([proc,func],lcp);
insymbol;
WITH lcp↑ DO
IF pfdeckind=standard THEN error(510)
ELSE
BEGIN
IF pfkind=actual THEN lcp1:=next
ELSE lcp1:=fparam;
IF compparam(nxt↑.fparam,lcp1) THEN
IF nxt↑.klass<>klass THEN error(503)
ELSE
IF NOT comptypes(idtype,nxt↑.idtype) THEN
error(555)
ELSE
BEGIN
increment_regc;
p:=level-pflev;
IF pfkind=actual THEN
IF language<>pascalsy THEN
error(510)
ELSE
BEGIN
IF p=0 THEN
macro3(514B(*HRLZ*),regc,basis)
ELSE IF p=1 THEN
macro4(514B(*HRLZ*),regc,basis,-1)
ELSE IF p>1 THEN
BEGIN
macro4(550B(*HRRZ*),regc,basis,-1);
FOR i:=3 TO p DO macro4(550B(*HRRZ*),regc,regc,-1);
macro4(514B(*HRLZ*),regc,regc,-1)
END;
IF pfaddr=0 THEN
BEGIN
macro3(541B(*HRRI*),regc,linkchain[p]);
linkchain[p]:=ic-1;
IF externdecl THEN code_reference↑[cix]:=externref
ELSE
code_reference↑[cix]:=forwardref
END
ELSE macro3r(541B(*HRRI*),regc,pfaddr)
END
ELSE
BEGIN
IF p=0 THEN macro4(200B(*MOVE*),regc,basis,pfaddr)
ELSE
BEGIN
macro4(200B(*MOVE*),regc,basis,-1);
FOR i:=2 TO p DO
macro4(200B(*MOVE*),regc,regc,-1);
macro4(200B(*MOVE*),regc,regc,pfaddr)
END
END
END
END
END
ELSE (* NXT↑.KLASS = VARS *)
BEGIN
expression(fsys + [comma,rparent],onfixedregc);
IF gattr.typtr <> NIL THEN
IF nxt <> NIL THEN
BEGIN
lsp := nxt↑.idtype;
IF lsp <> NIL THEN
IF nxt↑.vkind = actual THEN
IF lsp↑.size <= 2 THEN
BEGIN
load(gattr);
IF comptypes(realptr,lsp) THEN makereal(gattr)
END
ELSE
BEGIN
(* 25. PUT CHARACTER CONSTANTS IN A PLACE IN MEMORY.*)
IF stringpack THEN
IF lsp = sstringptr THEN
WITH gattr DO
if kind = cst then
begin
IF typtr↑.bitsize = 7 THEN
charconstant(chr(cval.ival));
end
else if kind = expr then
saveexpr;
load_address;
IF fcp↑.language <> pascalsy THEN code_array↑.instruction[cix].instr := 515B(*HRLZI*)
END
ELSE (*var parameters*)
begin
IF lsp↑.form = files THEN
BEGIN
IF last_file <> NIL THEN
IF last_file↑.name = 'TTY ' THEN ttyread := true
ELSE
(* 13. REWRITE OUTPUT ONLY IF NEEDED.*)
IF last_file↑.name = 'OUTPUT ' THEN
outputwrite := true
END;
IF gattr.kind = varbl THEN load_address
ELSE error(463);
end;
IF NOT comptypes(lsp,gattr.typtr) THEN error(503)
ELSE
(* 25. REJECT NON-SSTRING ON VAR PARAMETERS.*)
IF stringpack THEN
IF lsp = sstringptr THEN
WITH sstringlength↑ DO
IF nxt↑.vkind = formal THEN
BEGIN
IF value[count]
<> xtrastrglgth THEN
error(469);
count := count - 1;
END
ELSE
IF (gattr.typtr↑.form <> arrays) AND (value[count] = 1) THEN
value[count] := xtrastrglgth + 1;
END
END;
IF regc > fcp↑.highest_register THEN
BEGIN
IF topp_offset = 0 THEN
BEGIN
IF fcp↑.pfkind=formal THEN topp_offset:=fcp↑.parlistsize+1
ELSE
IF fcp↑.language = pascalsy THEN topp_offset:=fcp↑.parlistsize+1
ELSE
BEGIN
topp_offset := 1 + first_parameter;
REPEAT
WITH lnxt↑ DO
BEGIN
number_of_parameters := number_of_parameters +1;
topp_offset := topp_offset + 1;
IF vkind = actual THEN
IF idtype<>NIL THEN
topp_offset := topp_offset + idtype↑.size;
lnxt := next
END;
UNTIL lnxt = NIL;
start_of_parameterlist := 1 + first_parameter;
actual_parameter := start_of_parameterlist + number_of_parameters
END;
macro3(271B(*ADDI*),topp,topp_offset)
END ;
WITH nxt↑ DO
BEGIN
IF pascalcall THEN
BEGIN
IF klass<>vars THEN macro4(202B(*MOVEM*),regc,topp,pfaddr+1-topp_offset)
ELSE
IF (idtype↑.size <> 2) OR (vkind = formal) THEN macro4(202B(*MOVEM*),regc,topp,vaddr+1-topp_offset)
ELSE
BEGIN
macro4(202B(*MOVEM*),regc,topp,vaddr+2-topp_offset);
IF regc>fcp↑.highest_register+1 THEN
macro4(202B(*MOVEM*),regc-1,topp,vaddr+1-topp_offset)
END
END
ELSE
BEGIN
IF klass<>vars THEN error(468)
ELSE
IF vkind = actual THEN
IF idtype<>NIL THEN
BEGIN
IF idtype↑.size <= 2 THEN
BEGIN
IF idtype↑.size = 2 THEN
BEGIN
macro4(202B(*MOVEM*),regc,topp,actual_parameter+1-topp_offset);
regc := regc - 1
END;
macro4(202B(*MOVEM*),regc,topp,actual_parameter-topp_offset);
macro4(541B(*HRRI*),regc,topp,actual_parameter-topp_offset)
END
ELSE
BEGIN
macro4(541B(*HRRI*),regc,topp,actual_parameter-topp_offset);
macro4(251B(*BLT*),regc,topp,actual_parameter+idtype↑.size-1-topp_offset)
END;
actual_parameter := actual_parameter + idtype↑.size
END;
macro4(552B(*HRRZM*),regc,topp,start_of_parameterlist-topp_offset);
start_of_parameterlist := start_of_parameterlist + 1
END;
regc := fcp↑.highest_register
END
END;
(*REGC>FCP↑.HIGHEST_REGISTER*)
lst := nxt;
IF nxt <> NIL THEN nxt := nxt↑.next;
skipiferr([comma,rparent],256,fsys)
UNTIL sy <> comma;
parsingparameters := oldparsingparameters; (* 25.*)
sstringstart := oldsstringstart;
IF sy = rparent THEN insymbol
ELSE error(152)
END (*IF LPARENT*);
IF nxt<>NIL THEN error(554);
FOR i := 0 TO withix DO
WITH display[top-i] DO
IF (cindr<>0) AND (cindr<>basis) THEN macro4(202B(*MOVEM*),cindr,basis,clc);
WITH fcp↑ DO
BEGIN
IF lkind=formal THEN
BEGIN
IF topp_offset<>0 THEN macro3(275B(*SUBI*),topp,topp_offset)
END
ELSE
IF (language = pascalsy) AND (topp_offset <> 0) THEN macro3(275B(*SUBI*),topp,topp_offset)
ELSE
IF (language <> pascalsy) AND (topp_offset = 0) THEN
BEGIN
topp_offset:= first_parameter+2;
macro3(271B(*ADDI*),topp,topp_offset)
END;
IF pflev > 1 THEN p := level - pflev
ELSE p:= 0;
IF lkind = actual THEN
BEGIN
IF language <> pascalsy THEN
BEGIN
macro4(202b(*movem*),newreg,basis,lc);
lc := lc + 1;
if lc > lcmax then lcmax := lc;
macro3(515B(*HRLZI*),reg0,-number_of_parameters);
macro4(202B(*MOVEM*),reg0,topp,first_parameter-topp_offset);
macro4(202B(*MOVEM*),basis,topp,-topp_offset);
macro4(551B(*HRRZI*),basis,topp,first_parameter-topp_offset+1);
IF number_of_parameters = 0 THEN macro4(402B(*SETZM*),0,topp,first_parameter-topp_offset+1)
END;
IF stringpack THEN (* 25.*)
checksstringcalls;
IF pfaddr = 0 THEN
BEGIN
macro3r(260B(*PUSHJ*),topp,linkchain[p]); linkchain[p]:= ic-1;
IF externdecl THEN code_reference↑[cix] := externref
ELSE code_reference↑[cix] := forwardref
END
ELSE macro3r(260B(*PUSHJ*),topp,pfaddr-p);
IF language <> pascalsy THEN
BEGIN
macro3(275B(*SUBI*),topp,topp_offset);
IF klass = func THEN
BEGIN
macro4(202B(*MOVEM*),reg0,topp,2);
IF idtype↑.size = 2 THEN macro4(202B(*MOVEM*),reg1,topp,3)
END;
macro4(200B(*MOVE*),basis,topp,0);
macro4(200b(*move*),newreg,basis,lc-1);
END;
END
ELSE (*LKIND=FORMAL*)
BEGIN
IF p=0 THEN
BEGIN
macro4(550B(*HRRZ*),reg1,basis,pfaddr);
macro4(544B(*HLR*),basis,basis,pfaddr)
END
ELSE
BEGIN
macro4(550B(*HRRZ*),reg1,basis,-1);
FOR i:=2 TO p DO macro4(550B(*HRRZ*),reg1,reg1,-1);
macro4(544B(*HLR*),basis,reg1,pfaddr);
macro4(550B(*HRRZ*),reg1,reg1,pfaddr)
END;
IF stringpack THEN (* 25.*)
checksstringcalls;
macro4(260B(*PUSHJ*),topp,reg1,0)
END
END;
FOR i := 0 TO withix DO
WITH display[top-i] DO
IF (cindr<>0) AND (cindr<>basis) THEN macro4(200B(*MOVE*),cindr,basis,clc) ;
IF save_count > 0 THEN
BEGIN
IF save_count > 3 THEN
BEGIN
macro4(515B(*HRLZI*),reg1,basis,llc);
macro3(541B(*HRRI*),reg1,2);
macro3(251B(*BLT*),reg1,save_count+1)
END
ELSE FOR i := 1 TO save_count DO macro4(200B(*MOVE*),regin+i,basis,llc+i-1) ;
END ;
lc := llc;
gattr.typtr := fcp↑.idtype; regc := lregc
END (*CALL_NON_STANDARD*) ;
BEGIN (*PROFUNCALL*)
noload := false;
tty_message := false;
buffer_variable := false;
IF fcp↑.pfdeckind = standard THEN
BEGIN (* STANDARD PROCEDURES *)
lkey := fcp↑.key; lclass := fcp↑.klass;
IF fcp↑.klass = proc THEN
BEGIN
IF NOT (lkey IN [1..11,17,19,25..27,29]) THEN
IF sy = lparent THEN insymbol
ELSE error(153);
fsys := fsys + [rparent];
IF (lkey IN [5..8,10,11,26..29]) AND (regcmax <= 8) (*<--- REG2..8 USED BY RUNTIME-SUPPORT*) THEN error(317);
CASE lkey OF
1,2,3,4,
5,6:
BEGIN
getputresetrewrite;
IF no_right_parent THEN GOTO 666
END;
7, 8:
BEGIN
readreadln;
IF no_right_parent THEN GOTO 666
END;
9:
BEGIN
breakcall ;
IF no_right_parent THEN GOTO 666
END ;
10, 11:
BEGIN
writewriteln;
IF no_right_parent THEN GOTO 666
END;
12, 13:
packunpack;
14, 24:
newdispose;
17:
BEGIN
noload := true;
getlinenrcall
END;
19:
BEGIN
pagecall;
IF no_right_parent THEN GOTO 666
END;
20:
protection;
21:
calltocall;
22:
datecall;
23:
timecall;
25:
BEGIN
haltcall;
GOTO 666
END;
28:
messagecall;
OTHERS:
errandskip(169,fsys)
END
END
ELSE (* FCP↑.KLAS <> PROC : STANDARD FUNCTIONS *)
BEGIN
IF lkey IN [2..9,13..16,19..22] THEN
BEGIN
IF sy = lparent THEN insymbol
ELSE error(153);
IF lkey IN [2..9,13,14,18] THEN
expression(fsys + [rparent,comma],onregc);
IF lkey IN [3..5,8,9,13,14,18] THEN load(gattr)
END;
CASE lkey OF
1:
realtimecall;
2:
abscall;
3:
sqrcall;
5:
oddcall;
6:
ordcall;
7:
chrcall;
8,9:
predsucc;
10,11:
BEGIN
noload := true;
eofeoln;
IF no_right_parent THEN GOTO 666
END;
12:
clockcall;
13:
cardcall;
15,16:
lowerupperbound;
19,20:
minmax;
21,22:
firstlast;
OTHERS:
errandskip(169,fsys + [rparent])
END;
IF lkey IN [1,12] THEN GOTO 666
END;
IF sy = rparent THEN insymbol
ELSE error(152);
666:
END (*STANDARD PROCEDURES AND FUNCTIONS*)
ELSE call_non_standard
END (*PROFUNCALL*) ;
(* EXPRESSION[CHANGEBOOL, SEARCHCODE, SIMPLEEXPRESSION[TERM[FACTOR]]] *)
PROCEDURE expression; (*(FSYS: SETOFSYS; FVALUE:VALUEKIND)*)
VAR
jump_offset: 2..4;
default_offset: 4..5;
lattr: attr;
lop: operator;
lsize: addrrange;
default,jump: boolean;
boolregc,testregc,lregc1,lregc2:acrange;
linstr,linstr1: instrange;
setinclusion : boolean;
jmpadrifallequal : integer;
PROCEDURE changebool(VAR finstr: instrange);
BEGIN (*CHANGEBOOL*)
IF (finstr>=311B) AND (finstr<=313B) THEN finstr := finstr+4 (*CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG*)
ELSE
IF (finstr>=315B) AND (finstr<=317B) THEN finstr := finstr-4 (*SAME IN THE OTHER WAY*)
END (*CHANGEBOOL*);
PROCEDURE searchcode(finstr:instrange; fattr: attr);
PROCEDURE changeoperands(VAR finstr:instrange);
BEGIN (*CHANGEOPERANDS*)
IF finstr=311B(*CAML*) THEN finstr := 317B(*CAMG*)
ELSE
IF finstr = 313B(*CAMLE*) THEN finstr := 315B(*CAMGE*)
ELSE
IF finstr=315B(*CAMGE*) THEN finstr := 313B(*CAMLE*)
ELSE
IF finstr = 317B(*CAMG*) THEN finstr := 311B(*CAML*)
ELSE
IF finstr = 420B(*ANDCM*) THEN finstr := 410B(*ANDCA*)
ELSE
IF finstr = 410B(*ANDCA*) THEN finstr := 420B(*ANDCM*)
END (*CHANGEOPERANDS*);
BEGIN (*SEARCHCODE*)
WITH gattr DO
IF fattr.kind = expr THEN
BEGIN
generate_code(finstr,fattr.reg,gattr); reg := fattr.reg
END
ELSE
IF kind = expr THEN
BEGIN
changeoperands(finstr); generate_code(finstr,reg,fattr)
END
ELSE
IF (kind=varbl) AND ((packfg<>notpack)
OR (indexr>regin) AND (indexr<=regcmax) AND
((fattr.indexr<=regin) OR (fattr.indexr>regcmax))) THEN
BEGIN
load(gattr); changeoperands(finstr); generate_code(finstr,reg,fattr)
END
ELSE
BEGIN
load(fattr); generate_code(finstr,fattr.reg,gattr); reg := fattr.reg
END
END (*SEARCHCODE*);
PROCEDURE simpleexpression(fsys: setofsys);
VAR
lattr: attr; lop: operator; signed : boolean;
PROCEDURE term(fsys: setofsys);
VAR
lattr: attr; lop: operator;
PROCEDURE factor(fsys: setofsys);
VAR
lcp: ctp; lvp: csp; varpart: boolean;
cstpart: SET OF setrange; lsp: stp;
rangepart: boolean; lrmin: setrange;
loffset: 0..offset ;
BEGIN (*FACTOR*)
IF NOT (sy IN facbegsys) THEN
BEGIN
errandskip(173,fsys + facbegsys);
gattr.typtr := NIL
END;
IF sy IN facbegsys THEN
BEGIN
CASE sy OF
ident:
BEGIN
searchid([konst,vars,field,func],lcp);
insymbol;
CASE lcp↑.klass OF
func:
BEGIN
profuncall(fsys,lcp);
IF lcp↑.pfdeckind=declared THEN
BEGIN
WITH lcp↑,gattr DO
BEGIN
typtr :=idtype; kind :=varbl; packfg :=notpack;
vrelbyte := no;
vlevel :=1; dplmt :=2;
indexr := topp; indbit :=0;
IF typtr <> NIL THEN
IF typtr↑.size = 1 THEN load(gattr)
END
END
END;
konst:
WITH gattr, lcp↑ DO
BEGIN
typtr := idtype; kind := cst;
cval := values
END;
OTHERS:
selector(fsys,lcp)
END (*CASE KLASS*);
IF gattr.typtr <> NIL THEN WITH gattr, typtr↑ DO
IF form = subrange THEN (*ELIMINATE SUBRANGE TYPES*)
BEGIN
subkind := typtr;
typtr := rangetype (*TO SIMPLIFY LATER TESTS*)
END;
END;
intconst:
BEGIN
WITH gattr DO
BEGIN
typtr := intptr; kind := cst;
cval := val
END;
insymbol
END;
realconst:
BEGIN
WITH gattr DO
BEGIN
typtr := realptr; kind := cst;
cval := val
END;
insymbol
END;
stringconst:
BEGIN
WITH gattr DO
BEGIN
constant(fsys,typtr,cval) ; kind := cst
END
END;
lparent:
BEGIN
insymbol; expression(fsys + [rparent],onregc);
IF sy = rparent THEN insymbol
ELSE error(152)
END;
notsy:
BEGIN
insymbol; factor(fsys);
IF gattr.typtr = boolptr THEN
BEGIN
load(gattr); macro3(411B(*ANDCAI*),regc,1)
END
ELSE
BEGIN
error(359); gattr.typtr := NIL
END
END;
lbrack:
BEGIN
insymbol; cstpart := [ ]; varpart := false;
rangepart:=false;
new(lsp,power);
WITH lsp↑ DO
BEGIN
elset:=NIL; size:= 2
END;
IF sy = rbrack THEN
BEGIN
WITH gattr DO
BEGIN
typtr:=lsp; kind:=cst;
new(lvp,pset); lvp↑.pval := cstpart; cval.valp := lvp
END;
insymbol
END
ELSE
BEGIN
LOOP
increment_regc; increment_regc;
expression(fsys + [comma,rbrack,colon],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN
BEGIN
error(461); gattr.typtr := NIL
END
ELSE
IF comptypes(lsp↑.elset,gattr.typtr) THEN
WITH gattr DO
BEGIN
IF kind = cst THEN
BEGIN
IF comptypes(typtr,asciiptr) THEN cval.ival := cval.ival-offset;
IF (cval.ival < 0) OR (cval.ival > basemax) THEN error(268)
ELSE cstpart := cstpart + [cval.ival];
regc := regc - 2;
IF sy=colon THEN
BEGIN
rangepart:=true;
lrmin:=cval.ival
END
ELSE
IF rangepart THEN
BEGIN
lrmin:=lrmin+1;
IF lrmin > cval.ival THEN
error(451)
ELSE
WHILE (lrmin<cval.ival) DO
BEGIN
cstpart:=cstpart + [lrmin];
lrmin:=lrmin+1
END;
rangepart:=false
END
END
ELSE
BEGIN
IF (sy=colon) OR rangepart THEN
BEGIN
error(207);rangepart := NOT rangepart
END;
load(gattr);
regc := regc -1;
macro3(515B(*HRLZI*),regc-1,400000B);
macro2(400B(*SETZ*),regc);
IF runtime_check THEN
BEGIN
IF comptypes(typtr,asciiptr) THEN loffset := offset
ELSE loffset := 0 ;
macro3(301B(*CAIL*),regc+1,loffset);
macro3(303B(*CAILE*),regc+1,basemax+loffset);
support(errorinset)
END;
macro3(210B(*MOVN*),regc+1,regc+1);
IF comptypes(typtr,asciiptr) THEN macro4(246B(*LSHC*),regc-1,regc+1,offset)
ELSE macro4(246B(*LSHC*),regc-1,regc+1,0);
IF varpart THEN
BEGIN
macro3(434B(*IOR*),regc-3,regc-1);
macro3(434B(*IOR*),regc-2,regc);
regc := regc - 2
END
ELSE varpart := true;
kind := expr; reg := regc
END;
lsp↑.elset := typtr;
typtr :=lsp
END
ELSE error(360)
EXIT IF NOT(sy IN [comma,colon]);
insymbol
END;
IF sy = rbrack THEN insymbol
ELSE error(155);
IF varpart THEN
BEGIN
IF cstpart <> [ ] THEN
BEGIN
new(lvp,pset); lvp↑.pval := cstpart;
gattr.kind := cst; gattr.cval.valp := lvp;
generate_code(434B(*IOR*),regc,gattr)
END
END
ELSE
BEGIN
new(lvp,pset); lvp↑.pval := cstpart; gattr.cval.valp := lvp
END
END
END
END (*CASE*) ;
iferrskip(166,fsys)
END (*IF SY IN FACBEGSYS*)
END (*FACTOR*) ;
BEGIN (*TERM*)
factor(fsys + [mulop]);
WHILE sy = mulop DO
BEGIN
IF op IN [rdiv,idiv,imod] THEN load(gattr);
(*BECAUSE OPERANDS ARE NOT
ALLOWED TO BE CHOSEN*)
lattr := gattr; lop := op;
insymbol; factor(fsys + [mulop]);
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
CASE lop OF
mul:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr↑.form = power) THEN searchcode(404B(*AND*),lattr)
ELSE
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN searchcode(220B(*IMUL*),lattr)
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN searchcode(164B(*FMPR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
rdiv:
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN searchcode(174B(*FDVR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
idiv:
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN searchcode(230B(*IDIV*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END;
imod:
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN
BEGIN
searchcode(230B(*IDIV*),lattr);gattr.reg := gattr.reg+1
END
ELSE
BEGIN
error(311); gattr.typtr := NIL
END;
andop:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr = boolptr) THEN searchcode(404B(*AND*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END (*CASE*)
ELSE gattr.typtr := NIL;
regc:=gattr.reg
END (*WHILE*)
END (*TERM*) ;
BEGIN (*SIMPLEEXPRESSION*)
signed := false;
IF (sy = addop) AND (op IN [plus,minus]) THEN
BEGIN
signed := op = minus; insymbol
END;
term(fsys + [addop]);
IF signed THEN WITH gattr DO
IF typtr <> NIL THEN
IF (typtr = intptr) OR (typtr = realptr) THEN
CASE kind OF
cst:
IF typtr = intptr THEN cval.ival := - cval.ival
ELSE
BEGIN
increment_regc;
generate_code(210B(*MOVN*),regc,gattr)
END;
varbl:
BEGIN
increment_regc;
generate_code(210B(*MOVN*),regc,gattr)
END;
expr:
macro3(210B(*MOVN*),reg,reg)
END (*CASE*)
ELSE
BEGIN
error(311) ; gattr.typtr := NIL
END ;
WHILE sy = addop DO
BEGIN
IF aos = b2 THEN
IF (leftside.packfg=notpack) AND comptypes(leftside.typtr,intptr) THEN
BEGIN
leftside.typtr:=intptr; leftside.bpaddr:=gattr.bpaddr;
IF leftside=gattr THEN aos := b3
ELSE aos:=b0
END
ELSE aos := b0
ELSE aos := b0;
IF op=minus THEN load(gattr);
(*BECAUSE OPD MAY NOT BE CHOSEN*)
lattr := gattr; lop := op;
insymbol; term(fsys + [addop]);
IF aos=b3 THEN
IF gattr.kind<>cst THEN aos:=b0;
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
CASE lop OF
plus:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr↑.form = power) THEN searchcode(434B(*IOR*),lattr)
ELSE
IF (lattr.typtr = intptr) AND (gattr.typtr = intptr) THEN
BEGIN
IF aos=b3 THEN
IF gattr.cval.ival=1 THEN aos := aosinstr;
searchcode(270B(*ADD*),lattr)
END
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr=realptr) AND (gattr.typtr=realptr) THEN searchcode(144B(*FADR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
minus:
IF (lattr.typtr=intptr) AND (gattr.typtr=intptr) THEN
BEGIN
IF aos=b3 THEN
IF gattr.cval.ival=1 THEN aos := sosinstr;
searchcode(274B(*SUB*),lattr)
END
ELSE
BEGIN
makereal(lattr);
IF (lattr.typtr = realptr) AND (gattr.typtr = realptr) THEN searchcode(154B(*FSBR*),lattr)
ELSE
IF comptypes(lattr.typtr,gattr.typtr)
AND (lattr.typtr↑.form = power) THEN searchcode(420B(*ANDCM*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END;
orop:
IF comptypes(lattr.typtr,gattr.typtr)
AND (gattr.typtr = boolptr) THEN searchcode(434B(*IOR*),lattr)
ELSE
BEGIN
error(311); gattr.typtr := NIL
END
END (*CASE*)
ELSE gattr.typtr := NIL;
regc:=gattr.reg;
IF aos <= b3 THEN aos := b0
END (*WHILE*);
IF aos <= b3 THEN aos := b0
END (*SIMPLEEXPRESSION*) ;
BEGIN (*EXPRESSION*)
testregc := regc+1;
IF aos=b1 THEN aos:=b2
ELSE aos:=b0;
simpleexpression(fsys + [relop]);
IF sy = relop THEN
BEGIN
jump := false;
IF fvalue IN [onregc,onfixedregc] THEN
BEGIN
increment_regc; macro3(551B(*HRRZI*),regc,1); boolregc := regc
END;
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.size > 2 THEN load_address;
lregc1 := regc;
lattr := gattr;
lop := op;
IF (fvalue IN [onregc,onfixedregc]) AND (regc < boolregc) THEN regc := boolregc;
insymbol; simpleexpression(fsys);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.size > 2 THEN load_address;
lregc2 := regc;
IF (lattr.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
BEGIN
IF lop = inop THEN
IF gattr.typtr↑.form = power THEN
IF comptypes(lattr.typtr,gattr.typtr↑.elset) THEN
BEGIN
load(lattr);
IF (fvalue IN [onregc,onfixedregc]) AND (regc < boolregc) THEN regc := boolregc;
load(gattr); regc := gattr.reg - 1;
IF comptypes(lattr.typtr,asciiptr) THEN macro4(246B(*LSHC*),regc,lattr.reg,-offset)
ELSE macro4(246B(*LSHC*),regc,lattr.reg,0);
IF fvalue = truejmp THEN linstr := 305B(*CAIGE*)
ELSE linstr := 301B(*CAIL*);
macro2(linstr,regc)
END
ELSE
BEGIN
error(260); gattr.typtr := NIL
END
ELSE
BEGIN
error(213); gattr.typtr := NIL
END
ELSE
BEGIN
IF lattr.typtr <> gattr.typtr THEN makereal(lattr);
IF comptypes(lattr.typtr,gattr.typtr) THEN
BEGIN
lsize := lattr.typtr↑.size;
CASE lattr.typtr↑.form OF
power:
IF lop IN [ltop,gtop] THEN error(313);
arrays:
IF NOT string(lattr.typtr)
AND (lop IN [ltop,leop,gtop,geop]) THEN error(312);
pointer,
records:
IF lop IN [ltop,leop,gtop,geop] THEN error(312);
files:
error(314)
END;
WITH lattr.typtr↑ DO
BEGIN
IF size <= 2 THEN
BEGIN
default := true;
setinclusion := false;
jump_offset := 3;
default_offset := 4;
CASE lop OF
ltop:
BEGIN
linstr := 311B(*CAML*); linstr1 := 313B
END;
leop:
IF form = power THEN
BEGIN
searchcode(420B(*ANDCM*),lattr);
setinclusion := true
END
ELSE
BEGIN
linstr := 313B(*CAMLE*); linstr1 := 313B
END;
gtop:
BEGIN
linstr := 317B(*CAMG*); linstr1 := 315B
END;
geop:
IF form = power THEN
BEGIN
searchcode(410B(*ANDCA*),lattr);
setinclusion := true
END
ELSE
BEGIN
linstr := 315B(*CAMGE*); linstr1 := 315B
END;
neop:
BEGIN
linstr := 316B(*CAMN*);default := false
END;
eqop:
BEGIN
linstr := 312B(*CAME*); default := false
END
END;
IF fvalue IN [truejmp,falsejmp] THEN
BEGIN
IF (form = scalar) AND (gattr.kind = cst) THEN
IF lattr.typtr = realptr THEN jump := gattr.cval.valp↑.rval = 0.0
ELSE
IF gattr.cval.ival = 0 THEN jump := true;
IF (fvalue = truejmp) <> jump THEN changebool(linstr);
IF jump THEN linstr := linstr + 10B (*E.G CAML --> JUMPL *)
END;
IF size = 1 THEN
IF jump THEN
BEGIN
load(lattr); macro3(linstr,lattr.reg,0)
END
ELSE searchcode(linstr,lattr)
ELSE
IF setinclusion THEN
BEGIN
macro3(336B(*SKIPN*),0,gattr.reg);
macro3(332B(*SKIPE*),0,gattr.reg-1);
IF fvalue = truejmp THEN macro3r(254B(*JRST*),0,ic+2)
END
ELSE
BEGIN
load(lattr);
IF (fvalue IN [onregc,onfixedregc]) AND (regc<boolregc) THEN regc := boolregc;
load(gattr);
CASE fvalue OF
onregc,
onfixedregc,
falsejmp:
IF lop = eqop THEN jump_offset := 2;
truejmp:
IF lop <> eqop THEN
BEGIN
jump_offset := 2; default_offset := 5
END
END;
IF default THEN
BEGIN
macro3(linstr1,lattr.reg-1,gattr.reg-1);
macro3r(254B(*JRST*),0,ic + default_offset)
END;
macro3(312B(*CAME*),lattr.reg-1,gattr.reg-1);
macro3r(254B(*JRST*),0,ic+jump_offset);
macro3(linstr,lattr.reg,gattr.reg)
END
END
ELSE
BEGIN
macro3(551B(*HRRZI*),reg0,lsize);
increment_regc ;
macro4(200B(*MOVE*),regc,lregc1,0);
macro4(312B(*CAME*),regc,lregc2,0);
macro3r(254B(*JRST*),0,ic+5);
macro2(340B(*AOJ*),lregc1);
macro2(340B(*AOJ*),lregc2);
macro3r(367B(*SOJG*),reg0,ic-5);
jmpadrifallequal := 0;
CASE lop OF
ltop,gtop:
IF fvalue=truejmp THEN jmpadrifallequal := 3
ELSE jmpadrifallequal := 2;
leop,geop:
IF fvalue=truejmp THEN jmpadrifallequal := 2
ELSE jmpadrifallequal := 3;
eqop :
IF fvalue<>truejmp THEN jmpadrifallequal := 2;
neop :
IF fvalue=truejmp THEN jmpadrifallequal := 2
END;
IF jmpadrifallequal <> 0 THEN macro4r(254B(*JRST*),0,0,ic+jmpadrifallequal);
CASE lop OF
ltop,leop:
linstr := 311B(*CAML*);
gtop,geop:
linstr := 317B(*CAMG*)
END;
IF fvalue=truejmp THEN changebool(linstr);
IF lop IN [ltop,leop,gtop,geop] THEN macro4(linstr,regc,lregc2,0);
regc:=regc-2
END
END
END
ELSE error(260)
END;
IF fvalue IN [onregc,onfixedregc] THEN
BEGIN
macro3(400B(*SETZ*),boolregc,0); regc := boolregc
END
ELSE
IF NOT jump THEN macro3(254B(*JRST*),0,0)
END;
gattr.typtr := boolptr; gattr.kind := expr; gattr.reg := regc
END (*SY = RELOP*)
ELSE
IF fvalue IN [truejmp,falsejmp] THEN
BEGIN
load(gattr);
IF gattr.typtr<>boolptr THEN error (359);
IF fvalue = truejmp THEN linstr := 326B(*JUMPN*)
ELSE linstr := 322B(*JUMPE*);
macro3(linstr,gattr.reg,0)
END
ELSE
IF gattr.kind=expr THEN regc := gattr.reg;
IF fvalue = onfixedregc THEN WITH gattr DO
IF (typtr <> NIL) AND (kind=expr) THEN WITH typtr↑ DO
BEGIN
IF size = 2 THEN testregc := testregc + 1;
IF testregc <> regc THEN
BEGIN
IF size = 2 THEN macro3(200B(*MOVE*),testregc-1,regc-1);
macro3(200B(*MOVE*),testregc,regc); regc := testregc;reg := regc
END
END
END (*EXPRESSION*) ;
(* ASSIGNMENT[STOREGLOBALS[STOREWORD,GETNEWGLOBPTR]] *)
PROCEDURE assignment(fcp: ctp);
VAR
slattr: attr;
cmin, cmax: valu;
leftside_real: boolean;
linstr: instrange;
oldix: coderange;
oldic: addrrange;
%13 (* 17.*)
PROCEDURE storeglobals ;
TYPE
changeform = (ptrw,intw,reelw,psetw,strgw,instw) ;
VAR
change : RECORD
CASE kw : changeform OF
ptrw: (wptr :gtp (*TO ALLOW NIL*)) ;
intw: (wint : integer ; wint1 : integer (*TO PICK UP SECOND WORD OF SET*)) ;
reelw: (wreel: real) ;
psetw: (wset : SET OF setrange) ;
strgw: (wstrg: charword) ;
instw: (winst: pdp10instr)
END ;
i: 1..strglgth; j: 0..5;
PROCEDURE storeword ;
BEGIN (*STOREWORD*)
cix := cix + 1 ;
IF cix > code_size THEN
BEGIN
cix := 0;
IF NOT overrun THEN
BEGIN
overrun := true;
error_with_text(356,'INITPROCD.')
END
END ;
WITH cglobptr↑ DO
BEGIN
code_array↑.instruction[cix] := change.winst ;
lastglob := lastglob + 1
END
END (*STOREWORD*) ;
PROCEDURE getnewglobptr ;
VAR
lglobptr : gtp ;
BEGIN (*GETNEWGLOBPTR*)
new(lglobptr) ;
WITH lglobptr↑ DO
BEGIN
nextglobptr := NIL ;
firstglob := 0
END ;
IF cglobptr <> NIL THEN cglobptr↑.nextglobptr := lglobptr ;
cglobptr := lglobptr
END (*GETNEWGLOBPTR*);
BEGIN
(*STOREGLOBALS*)
IF fglobptr = NIL THEN
BEGIN
getnewglobptr ;
fglobptr := cglobptr
END
ELSE
IF leftside.dplmt <> cglobptr↑.lastglob + 1 THEN getnewglobptr ;
WITH change,cglobptr↑,gattr,cval DO
BEGIN
IF firstglob = 0 THEN
BEGIN
IF leftside.packfg<>notpack THEN
IF errlist[errinx].arw<>507 THEN error(507);
firstglob := leftside.dplmt ;
lastglob := firstglob - 1 ;
fcix := cix + 1
END ;
CASE typtr↑.form OF
scalar,
subrange:
BEGIN
IF leftside_real THEN
IF typtr=intptr THEN wreel := ival
ELSE wreel := valp↑.rval
ELSE wint := ival ;
storeword
END ;
pointer :
BEGIN
wptr := NIL ; storeword
END ;
power :
BEGIN
wset := valp↑.pval ; storeword ;
wint := wint1 (*GET SECOND WORD OF SET*) ;
storeword
END ;
arrays :
WITH valp↑,change DO
BEGIN
j := 0; wint := 0;
FOR i := 1 TO slgth DO
BEGIN
j := j + 1;
wstrg[j] := sval[i];
IF j=5 THEN
BEGIN
j := 0;
storeword; wint := 0
END
END;
IF j<>0 THEN storeword
END;
OTHERS :
error(411)
END (*CASE*)
END (* WITH *)
END (* STOREGLOBALS *) ;
(* 17.*) \
BEGIN (*ASSIGNMENT*)
selector(fsys + [becomes],fcp);
IF sy = becomes THEN
BEGIN
leftside := gattr;
leftside_real := comptypes(leftside.typtr,realptr);
IF NOT runtime_check THEN
BEGIN
aos := b1; oldix:=cix; oldic:=ic
END;
insymbol;
expression(fsys,onregc);
IF (leftside.typtr <> NIL) AND (gattr.typtr <> NIL) THEN
IF comptypes(leftside.typtr,gattr.typtr) OR
leftside_real AND (gattr.typtr=intptr) THEN
%24
BEGIN (* 24.*) \
IF initglobals THEN
IF gattr.kind = cst THEN %13 storeglobals (* 17.*) \
ELSE error(504)
%13
ELSE \ %24 ;
(* 24.*) \
IF (gattr.kind=cst) AND (gattr.cval.ival=0) AND
(leftside.packfg<>packk) THEN WITH leftside DO
BEGIN
fetch_basis(leftside);
WITH typtr↑ DO
IF form = subrange THEN
IF leftside_real THEN
BEGIN
IF (vmin.valp↑.rval > 0) OR (vmax.valp↑.rval < 0) THEN error(367)
END
ELSE
IF (vmin.ival > 0) OR (vmax.ival < 0) THEN error(367) ;
CASE packfg OF
notpack:
linstr := 402B(*SETZM*);
hwordl:
linstr := 553B(*HRRZS*);
hwordr:
linstr := 513B(*HLLZS*)
END (*CASE*);
macro(vrelbyte,linstr,0,indbit,indexr,dplmt)
END
ELSE
IF aos >= aosinstr THEN
BEGIN
ic := oldic; cix := oldix;
IF aos=aosinstr THEN generate_code(350B(*AOS*),0,leftside)
ELSE generate_code(370B(*SOS*),0,leftside)
END
ELSE
CASE leftside.typtr↑.form OF
scalar,
pointer,
power:
BEGIN
load(gattr);
IF (gattr.typtr=intptr) AND leftside_real THEN makereal(gattr);
store(gattr.reg,leftside)
END;
subrange:
BEGIN
cmin := leftside.typtr↑.vmin;
cmax := leftside.typtr↑.vmax;
IF leftside_real THEN
IF gattr.typtr=intptr THEN makereal(gattr);
IF gattr.kind = cst THEN WITH gattr DO
BEGIN
IF leftside_real THEN
BEGIN
IF (cval.valp↑.rval < cmin.valp↑.rval)
OR (cval.valp↑.rval > cmax.valp↑.rval) THEN error(367)
END (*LEFTSIDE_REAL*)
ELSE
IF (cval.ival < cmin.ival) OR (cval.ival > cmax.ival) THEN error (367);
load(gattr)
END (*=CST*)
ELSE
IF runtime_check AND ((gattr.kind<>varbl) OR (gattr.subkind <> leftside.typtr)) THEN
BEGIN
load(gattr);
WITH slattr DO
BEGIN
typtr:= gattr.typtr;
kind := cst;
cval := cmax
END;
generate_code(317B(*CAMG*),regc,slattr);
slattr.kind:=cst;
slattr.cval:=cmin;
generate_code(315B(*CAMGE*),regc,slattr);
support(errorinassignment)
END (*RUNTIMECHECK*)
ELSE load(gattr);
store(gattr.reg,leftside)
END;
arrays,
records:
IF gattr.typtr↑.size = 1 THEN
BEGIN
load(gattr) ; store(gattr.reg,leftside)
END
ELSE WITH leftside DO
BEGIN
load_address ;
code_array↑.instruction[cix].instr := 515B(*HRLZI*) ;
fetch_basis(leftside);
macro(vrelbyte,541B(*HRRI*),regc,indbit,indexr,dplmt);
IF indbit=0 THEN macro5(vrelbyte,251B(*BLT *),regc,indexr,dplmt+typtr↑.size-1)
ELSE
BEGIN
increment_regc ;
macro3(200B(*MOVE*),regc,regc-1);
macro4(251B(*BLT *),regc,regc-1,typtr↑.size-1)
END
END;
files:
error(361)
END (*CASE*)
%24
END (* 24.*) \
ELSE (* NOT COMPTYPES ... *)
error(260);
aos := b0
END (*SY = BECOMES*)
ELSE error(159)
END (*ASSIGNMENT*) ;
(*GOTOSTATEMENT,COMPOUNDSTATEMENT,IFSTATEMENT,CASESTATEMENT,REPEATSTATEMENT,WHILESTATEMENT,FORSTATEMENT,LOOPSTATEMENT,WITHSTATEMENT*)
PROCEDURE gotostatement;
VAR
lcp: ctp; lscope: levrange;
BEGIN (*GOTOSTATEMENT*)
IF counting THEN (* 28.*)
addnewcounter;
IF sy = intconst THEN
BEGIN
searchid([labels],lcp);
IF lcp <> NIL THEN
WITH lcp↑ DO
BEGIN
lscope := level - scope;
macro3r(254B(*JRST*),0,goto_chain);
goto_chain := ic-1; code_reference↑[cix] := gotoref;
IF lscope > 0 THEN
%13 (* 14.*)
IF (scope = 1) AND external THEN error(508)
ELSE (* 14.*) \
exit_jump := true
END;
insymbol
END
ELSE error(255)
END (*GOTOSTATEMENT*) ;
PROCEDURE compoundstatement;
BEGIN (*COMPOUNDSTATEMENT*)
LOOP
REPEAT
statement(fsys,statends)
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = endsy THEN insymbol
ELSE error(163)
END (*COMPOUNDSTATEMENET*) ;
PROCEDURE ifstatement;
VAR
lcix1,lcix2: coderange;
BEGIN (*IFSTATEMENT*)
expression(fsys + [thensy],falsejmp);
lcix1 := cix;
IF sy = thensy THEN
BEGIN
insymbol;
IF counting THEN (* 28.*)
addnewcounter;
END
ELSE error(164);
statement(fsys + [elsesy],statends + [elsesy]);
IF sy = elsesy THEN
BEGIN
macro3(254B(*JRST*),0,0); lcix2 := cix;
insert_address(right,lcix1,ic);
insymbol;
IF counting THEN (* 28.*)
addnewcounter;
statement(fsys,statends);
insert_address(right,lcix2,ic)
END
ELSE insert_address(right,lcix1,ic)
END (*IFSTATEMENT*) ;
PROCEDURE casestatement;
LABEL
888,999;
TYPE
cip = ↑caseinfo;
caseinfo = PACKED
RECORD
next: cip;
csstart: addrrange;
csend: coderange;
cslab: integer
END;
VAR
lsp, lsp1: stp;
fstptr, lpt1, lpt2, lpt3, othersptr: cip;
lval: valu;
lic, laddr, jumpaddr, lmin, lmax: addrrange;
lcix: coderange;
PROCEDURE insertbound(fcix: coderange; fic: addrrange; bound: integer);
VAR
lcix1:coderange;
lic1: addrrange;
lattr:attr;
BEGIN (*INSERTBOUND*)
IF bound >= 0 THEN insert_address(no,fcix,bound)
ELSE
BEGIN
lcix1:=cix; lic1 := ic;
cix:=fcix; ic := fic;
WITH lattr DO
BEGIN
kind:=cst;
cval.ival:=bound;
typtr:=NIL
END;
deposit_constant(int,lattr);
cix:=lcix1; ic:= lic1;
WITH code_array↑.instruction[fcix] DO
instr:=instr+10B (*CAILE-->CAMLE, CAIL-->CAML*)
END
END (*INSERTBOUND*);
BEGIN (*CASESTATEMENT*)
othersptr:=NIL;
expression(fsys + [ofsy,comma,colon],onregc);
load(gattr);
macro2(301B(*CAIL*),regc); (*<<<---- LMIN IS INSERTED HERE*)
macro2(303B(*CAILE*),regc); (*<<<---- LMAX IS INSERTED HERE*)
macro2(254B(*JRST*),0); (*<<<---- START OF "OTHERS" IS INSERTED HERE*)
macro(no,254B(*JRST*),0,1,regc,0);(*<<<---- START OF JUMP TABLE IS INSERTED HERE*)
lcix := cix; lic := ic;
lsp := gattr.typtr;
IF lsp <> NIL THEN
IF (lsp↑.form <> scalar) OR (lsp = realptr) THEN
BEGIN
error(315); lsp := NIL
END;
IF sy = ofsy THEN insymbol
ELSE error(160);
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
fstptr := NIL; lpt3 := NIL;
LOOP
LOOP
constant(fsys + [comma,colon],lsp1,lval);
IF lsp <> NIL THEN
IF comptypes(lsp,lsp1) THEN
BEGIN
lpt1 := fstptr; lpt2 := NIL;
IF abs(lval.ival) > hwcstmax THEN error(316);
WHILE lpt1 <> NIL DO
WITH lpt1↑ DO
BEGIN
IF cslab <= lval.ival THEN
BEGIN
IF cslab = lval.ival THEN error(261);
GOTO 888
END;
lpt2 := lpt1; lpt1 := next
END;
888:
new(lpt3);
WITH lpt3↑ DO
BEGIN
next := lpt1; cslab := lval.ival;
csstart := ic; csend := 0
END;
IF lpt2 = NIL THEN fstptr := lpt3
ELSE lpt2↑.next := lpt3
END
ELSE error(505)
EXIT IF sy <> comma;
insymbol
END;
IF sy = colon THEN
BEGIN
insymbol;
IF counting THEN (* 28.*)
addnewcounter;
END
ELSE error(151);
REPEAT
statement(fsys,statends)
UNTIL NOT (sy IN statbegsys);
IF lpt3 <> NIL THEN
BEGIN
macro2(254B(*JRST*),0); lpt3↑.csend := cix
END;
(* 13. ALLOW EXTRA SEMICOLONS.*)
WHILE sy = semicolon DO
insymbol;
EXIT IF sy IN (fsys + statends);
IF sy=otherssy THEN
BEGIN
insymbol;
IF sy=colon THEN insymbol
ELSE error(151);
new(othersptr);
WITH othersptr↑ DO
BEGIN
csstart:=ic;
REPEAT
statement(fsys,statends)
UNTIL NOT(sy IN statbegsys);
macro2(254B(*JRST*),0);
csend:=cix;
(* 13. ALLOW EXTRA SEMICOLONS *)
WHILE sy = semicolon DO
insymbol;
GOTO 999
END
END
END;
999:
IF fstptr <> NIL THEN
BEGIN
lmax := fstptr↑.cslab;
(*REVERSE POINTERS*)
lpt1 := fstptr; fstptr := NIL;
REPEAT
lpt2 := lpt1↑.next; lpt1↑.next := fstptr;
fstptr := lpt1; lpt1 := lpt2
UNTIL lpt1 = NIL;
lmin := fstptr↑.cslab;
insertbound(lcix-2,lic-2,lmax);
insertbound(lcix-3,lic-3,lmin);
insert_address(right,lcix,ic-lmin);
IF (lmax - lmin) < (code_size - cix) THEN
BEGIN
laddr := ic + lmax - lmin + 1;
IF othersptr = NIL THEN jumpaddr := laddr
ELSE
BEGIN
insert_address(right,othersptr↑.csend,laddr);
jumpaddr:=othersptr↑.csstart
END;
insert_address(right,lcix-1,jumpaddr);
REPEAT
WITH fstptr↑ DO
BEGIN
WHILE cslab > lmin DO
BEGIN
generate_word(right,0,jumpaddr); lmin := lmin + 1
END;
generate_word(right,0,csstart);
IF csend <> 0 THEN insert_address(right,csend,laddr);
fstptr := next; lmin := lmin + 1
END
UNTIL fstptr = NIL
END
ELSE
BEGIN
IF NOT overrun THEN
BEGIN
overrun := true;
IF fprocp = NIL THEN error_with_text(356,'MAIN ')
ELSE error_with_text(356,fprocp↑.name)
END;
cix := 0
END
END;
IF sy = endsy THEN insymbol
ELSE error(163)
END (*CASESTATEMENT*) ;
PROCEDURE repeatstatement;
VAR
laddr: addrrange;
BEGIN (*REPEATSTATEMENT*)
laddr := ic;
IF counting THEN (* 28.*)
entercount := true;
LOOP
REPEAT
statement(fsys + [untilsy],statends + [untilsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = untilsy THEN
BEGIN
insymbol; expression(fsys,falsejmp); insert_address(right,cix,laddr)
END
ELSE error(202)
END (*REPEATSTATEMENT*) ;
PROCEDURE whilestatement;
VAR
laddr: addrrange;
lcix: coderange;
BEGIN (*WHILESTATEMENT*)
laddr := ic;
expression(fsys + [dosy],falsejmp);
lcix := cix;
IF sy = dosy THEN
BEGIN (* 28.*)
insymbol;
IF counting THEN
entercount := true;
END
ELSE error(161);
statement(fsys,statends);
macro3r(254B(*JRST*),0,laddr);
insert_address(right,lcix,ic)
END (*WHILESTATEMENT*) ;
PROCEDURE forstatement;
VAR
lattr: attr;
lsp: stp;
lsy: symbol;
lcix: coderange;
laddr,ldplmt: addrrange;
linstr: instrange;
lregc,lindreg: acrange;
lindbit: ibrange;
lrelbyte: relbyte;
addtolc: addrrange;
BEGIN (*FORSTATEMENT*)
IF sy = ident THEN
BEGIN
searchid([vars],lcp);
WITH lcp↑, lattr DO
BEGIN
typtr := idtype; kind := varbl;
IF vkind = actual THEN
BEGIN
vlevel := vlev;
IF vlev > 1 THEN vrelbyte := no
ELSE vrelbyte := right;
dplmt := vaddr; indexr :=0; packfg := notpack;
indbit:=0
END
ELSE
BEGIN
error(364); typtr := NIL
END
END;
IF lattr.typtr <> NIL THEN
IF comptypes(realptr,lattr.typtr) OR (lattr.typtr↑.form > subrange) THEN
BEGIN
error(365); lattr.typtr := NIL
END;
insymbol
END
ELSE
BEGIN
errandskip(209,fsys + [becomes,tosy,downtosy,dosy]);
lattr.typtr := NIL
END;
IF sy = becomes THEN
BEGIN
insymbol; expression(fsys + [tosy,downtosy,dosy],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN error(315)
ELSE
IF comptypes(lattr.typtr,gattr.typtr) THEN load(gattr)
ELSE error(556);
lregc := gattr.reg
END
ELSE errandskip(159,fsys + [tosy,downtosy,dosy]);
IF sy IN [tosy,downtosy] THEN
BEGIN
lsy := sy; insymbol; expression(fsys + [dosy],onregc);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form <> scalar THEN error(315)
ELSE
IF comptypes(lattr.typtr,gattr.typtr) THEN
BEGIN
addtolc := 0 ;
WITH gattr DO
IF ((kind = varbl) AND
(((vlevel > 1) AND (vlevel < level)) OR
(packfg <> notpack) OR
((indexr > 0) AND (indexr <= regcmax)))) OR
(kind = expr) THEN
BEGIN
load(gattr); macro4(202B(*MOVEM*),regc,basis,lc); addtolc := 1;
kind := varbl ; indbit := 0 ; indexr := basis ; vlevel := 1;
dplmt := lc ; packfg := notpack ; vrelbyte := no
END ;
fetch_basis(lattr);
WITH lattr DO
BEGIN
IF (indexr>0) AND (indexr<=regcmax) THEN
BEGIN
macro(no,551B(*HRRZI*),indexr,indbit,indexr,dplmt);
lindbit := 1; ldplmt := lc+addtolc; lindreg := basis ;
macro4(202B(*MOVEM*),indexr,basis,ldplmt);
addtolc := addtolc + 1
END
ELSE
BEGIN
lindbit := indbit; lindreg := indexr; ldplmt := dplmt
END;
lrelbyte:= vrelbyte
END;
macro(lrelbyte,202B(*MOVEM*),lregc,lindbit,lindreg,ldplmt);
IF lsy = tosy THEN linstr := 313B(*CAMLE*)
ELSE linstr := 315B(*CAMGE*);
laddr := ic;
generate_code(linstr,lregc,gattr)
END
ELSE error(556)
END
ELSE errandskip(251,fsys + [dosy]);
macro3(254B(*JRST*),0,0); lcix :=cix;
IF sy = dosy THEN
BEGIN (* 28.*)
insymbol;
IF counting THEN
entercount := true;
END
ELSE error(161);
lc := lc + addtolc;
IF lc > lcmax THEN lcmax:=lc;
statement(fsys,statends);
lc := lc - addtolc;
IF lsy = tosy THEN linstr := 350B(*AOS*)
ELSE linstr := 370B(*SOS*);
macro(lrelbyte,linstr,lregc,lindbit,lindreg,ldplmt);
macro3r(254B(*JRST*),0,laddr); insert_address(right,lcix,ic)
END (*FORSTATEMENT*) ;
PROCEDURE loopstatement;
VAR
laddr: addrrange;
lcix: coderange;
BEGIN (*LOOPSTATEMENT*)
laddr := ic;
IF counting THEN (* 28.*)
addnewcounter;
LOOP
REPEAT
statement(fsys + [exitsy],statends + [exitsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = exitsy THEN
BEGIN
insymbol;
IF sy = ifsy THEN
BEGIN
insymbol; expression(fsys + [semicolon,endsy],truejmp)
END
ELSE errandskip(162,fsys + [semicolon,endsy]);
lcix := cix;
statement(fsys,statends); (* 28.*)
IF counting THEN
entercount := true;
LOOP
WHILE (sy IN statbegsys) DO (* 28.*)
statement(fsys,statends)
EXIT IF sy <> semicolon;
insymbol;
statement(fsys,statends);
END;
macro3r(254B(*JRST*),0,laddr); insert_address(right,lcix,ic)
END
ELSE error(165);
IF sy = endsy THEN insymbol
ELSE error(163)
END (*LOOPSTATEMENT*) ;
PROCEDURE withstatement;
VAR
lcp: ctp; oldlc: addrrange; lcnt1: disprange; oldregc: acrange;
BEGIN (*WITHSTATEMENT*)
lcnt1 := 0; oldregc := regcmax; oldlc := lc;
LOOP
IF sy = ident THEN
BEGIN
searchid([vars,field],lcp); insymbol
END
ELSE
BEGIN
error(209); lcp := uvarptr
END;
selector(fsys + [comma,dosy],lcp);
IF gattr.typtr <> NIL THEN
IF gattr.typtr↑.form = records THEN
IF top < displimit THEN
BEGIN
top := top + 1; lcnt1 := lcnt1 + 1; withix := withix + 1;
WITH display[top], gattr DO
BEGIN
fname := typtr↑.fstfld;
occur := crec;
IF indbit = 1 THEN get_parameter_address;
fetch_basis(gattr);
IF (indexr<>0) AND (indexr <> basis) THEN
BEGIN
macro3(550B(*HRRZ*),regcmax,indexr);
indexr := regcmax;
regcmax := regcmax-1;
IF regcmax<regc THEN
BEGIN
error(317);
regc := regcmax
END
END;
clev := vlevel; crelbyte := vrelbyte;
cindr := indexr; cindb:=indbit;
cdspl := dplmt;
clc := lc;
IF (cindr<>0) AND (cindr<>basis) THEN
BEGIN
lc := lc + 1;
IF lc>lcmax THEN lcmax := lc
END
END
END
ELSE error(404)
ELSE error(308)
EXIT IF sy <> comma;
insymbol
END;
IF sy = dosy THEN insymbol
ELSE error(161);
statement(fsys,statends);
regcmax:=oldregc;
top := top - lcnt1; lc := oldlc; withix := withix - lcnt1
END (*WITHSTATEMENT*) ;
(* ]STATEMENT ]BODY ]BLOCK *)
BEGIN (*STATEMENT*)
IF sy = intconst THEN (*LABEL*)
BEGIN
searchid([labels],lcp);
IF lcp <> NIL THEN
WITH lcp↑ DO
BEGIN
IF label_address = 0 THEN
BEGIN
IF exit_jump THEN macro3r(324B(*JUMPA*),reg0,ic+3);
label_address := ic;
IF exit_jump THEN
BEGIN
macro3r(200B(*MOVE*),basis,jump_table[jump_index]); code_reference↑[cix] := saveref;
macro3r(200B(*MOVE*),topp,jump_table[jump_index] + 1); code_reference↑[cix] := saveref;
jump_table[jump_index] := label_address
END
END
ELSE error(211);
IF scope <> level THEN error(352)
END;
insymbol;
IF sy = colon THEN
BEGIN (* 28.*)
insymbol;
IF counting THEN
BEGIN
addnewcounter; entercount := false;
END;
END
ELSE error(151)
END (* OF LABEL *);
IF NOT (sy IN fsys + [ident]) THEN errandskip(166,fsys);
IF sy IN statbegsys + [ident] THEN
IF initglobals (* INSIDE AN INITPROCEDURE *) THEN
IF sy <> ident THEN error(462)
ELSE
BEGIN
searchid([vars,field,func,proc],lcp); insymbol;
IF lcp↑.klass = proc THEN error(462)
ELSE assignment(lcp);
%24 REGC := REGIN; (* 24.*) \
END
ELSE (*...NOT INITGLOBALS*)
BEGIN
IF entercount THEN
BEGIN (* 28.*)
addnewcounter; entercount := false;
END;
IF debug_switch THEN put_linenumber;
regc := regin;
CASE sy OF
ident:
BEGIN
searchid([vars,field,func,proc],lcp); insymbol;
WITH lcp↑ DO
IF klass = proc THEN profuncall(fsys,lcp)
else
begin
IF (klass = vars) AND (vlev = 0) AND (sy = arrow) AND
(idtype↑.form = files) AND (name = 'TTY ') THEN
BEGIN
id := 'TTYOUTPUT '; searchid([vars],lcp)
END;
assignment(lcp);
end;
END;
beginsy:
BEGIN
insymbol; compoundstatement
END;
gotosy:
BEGIN
insymbol; gotostatement
END;
ifsy:
BEGIN
insymbol; ifstatement
END;
casesy:
BEGIN
insymbol; casestatement
END;
whilesy:
BEGIN
insymbol; whilestatement
END;
repeatsy:
BEGIN
insymbol; repeatstatement
END;
loopsy:
BEGIN
insymbol; loopstatement
END;
forsy:
BEGIN
insymbol; forstatement
END;
withsy:
BEGIN
insymbol; withstatement
END
END (*CASE*) ;
(* RE-INITIALIZE REGISTER COUNTER TO AVOID OVERFLOW DURING SUBSEQUENT
EXPRESSION EVALUATIONS IN REPEATSTATEMENT OR LOOPSTATEMENT *)
regc := regin
END (*..NOT INITGLOBALS*);
skipiferr(statends,506,fsys)
END (*STATEMENT*) ;
BEGIN
(*BODY*)
regcmax:=within; withix := -1; firstkonst := NIL;
reg2_saved := false;
%13 (* 18.*)
IF NOT entry_done THEN
BEGIN
entry_done:= true;
write_machine_code(write_entry);
write_machine_code(write_name);
write_machine_code(write_hiseg)
END;
(* 18.*) \
cix := -1 ;
%13 (* 24.*)
IF initglobals THEN (* INSIDE AN INITPROCEDURE IN PASCAL*)
BEGIN
cglobptr := NIL ;
LOOP
IF sy <> endsy THEN statement([semicolon,endsy],[semicolon,endsy])
EXIT IF sy <> semicolon ;
insymbol
END ;
IF sy = endsy THEN insymbol
ELSE error(163) ;
write_machine_code(write_globals)
END
ELSE (* NOT INITGLOBALS *)
(* 24.*) \
BEGIN
enterbody;
IF fprocp <> NIL THEN
%24 (* 24.*)
BEGIN
IF INITGLOBALS THEN
INITPRADDR[INITPROCCOUNT] := PFSTART;
(* 24.*) \
fprocp↑.pfaddr:= pfstart
%24 END \
ELSE
%24 (* 24.*)
BEGIN
FOR I := 0 TO INITPROCCOUNT DO
MACRO3R(260B(*PUSHJ*),TOPP,INITPRADDR[I]);
(* 24.*) \
lc:= 1;
%24 END;
\
lcmax:=lc;
LOOP
REPEAT
statement(fsys + [semicolon,endsy],[semicolon,endsy])
UNTIL NOT (sy IN statbegsys)
EXIT IF sy <> semicolon;
insymbol
END;
IF sy = endsy THEN insymbol
ELSE error(163);
leavebody;
insert_address(no,stacksize1,lcmax);
insert_address(no,stacksize2,lcmax);
write_machine_code(write_code);
IF debug THEN write_machine_code(write_debug);
write_machine_code(write_internals);
IF level = 1 THEN
BEGIN
write_machine_code(write_fileblocks);
%13 (* 18.*)
write_machine_code(write_counters); (* 28.*)
write_machine_code(write_symbols);
write_machine_code(write_library);
write_machine_code(write_start);
write_machine_code(write_end)
(* 18.*) \
END
END
END (*BODY*) ;
BEGIN (*BLOCK*)
new(heapmark);
dp := true; testpacked := false; forward_procedures := NIL; current_jump := 0;
IF genprocfile THEN
BEGIN
firstline := headline;
beginline := 0;
END;
REPEAT
WHILE sy IN blockbegsys - [beginsy] DO
BEGIN
IF sy = labelsy THEN
BEGIN
insymbol; labeldeclaration
END;
IF sy = constsy THEN
BEGIN
insymbol; constantdeclaration
END;
IF sy = typesy THEN
BEGIN
insymbol; typedeclaration
END;
lcpar := lc;
IF sy = varsy THEN
BEGIN
insymbol; variabledeclaration
END;
IF (level > 1) AND (sy = initprocsy) THEN errandskip(363,blockbegsys - [initprocsy]);
IF level = 1 THEN
BEGIN
IF lc > maxruncore * 1024 THEN
error_valued(470,lc);
WHILE sy = initprocsy DO
BEGIN
IF genprocfile THEN
BEGIN
headline := linecnt; beginline := 0;
END;
%13 (* 24.*)
insymbol ;
IF sy <> semicolon THEN errandskip(156,[beginsy])
ELSE insymbol ;
IF sy = beginsy THEN
BEGIN
new(globmark); initglobals := true ;
IF genprocfile THEN
beginline := linecnt;
insymbol ; body(fsys + [semicolon,endsy]) ;
IF genprocfile THEN
writeln(procfile,' INITPROCED',headline:6,beginline:6,linecnt:6);
IF sy = semicolon THEN insymbol
ELSE error(166) ;
initglobals := false; dispose(globmark)
END
ELSE error(201)
(* 24.*) \
%24 (* 24.*)
INITGLOBALS := TRUE;
IF INITPROCCOUNT = 99 THEN
ERROR(413)
ELSE
BEGIN
SY := IDENT;
ID := '.INITPRO ';
INITPROCCOUNT := INITPROCCOUNT + 1;
ID[ 9] := CHR(INITPROCCOUNT DIV 10 + ORD('0'));
ID[10] := CHR(INITPROCCOUNT MOD 10 + ORD('0'));
END;
PROCEDUREDECLARATION(TRUE);
INITGLOBALS := FALSE;
(* 24.*) \
END ;
lcmain := lc; testpacked := false;
IF counting THEN
BEGIN (* 28.*)
gotomarkers := lcmain;
lcmain := lcmain + 32; (*to leave space for markers for GOTO out of block*)
counter := 1; startofcounts := lcmain;
%13 lastlcmain := lcmain; \
%24
NEW(FIRSTCNTP);
FIRSTCNTP↑.NEXT := NIL;
LASTCNTP := FIRSTCNTP;
\
END;
END;
WHILE sy IN [proceduresy,functionsy] DO
BEGIN
lsy := sy; insymbol; proceduredeclaration(lsy=proceduresy)
END;
WHILE forward_procedures <> NIL DO
WITH forward_procedures↑ DO
BEGIN
IF forwdecl THEN error_with_text(465,name);
forward_procedures := testfwdptr
END;
skipiferr([beginsy],201,fsys)
END;
dp := false;
IF sy = beginsy THEN
BEGIN
IF genprocfile THEN
beginline := linecnt;
insymbol;
IF counting THEN (* 28.*)
entercount := true;
END
ELSE error (201);
body(fsys + [casesy]);
skipiferr(leaveblocksys,166,fsys)
UNTIL sy IN leaveblocksys;
IF genprocfile THEN
BEGIN
writeln(procfile,' ':(level-1)*4,currname,firstline:6,beginline:6,linecnt:6);
END;
dispose(heapmark)
END (*BLOCK*) ;
(* ]COMPILE,REPORTTIME,JUMPTO *)
BEGIN (* COMPILE *)
writeln(tty);
%13 write(tty, header:headlen, ': ',object_file:6); (* 14.*) \
%24 WRITE (TTY, HEADER:HEADLEN, ': ', SOURCE_FILE:6); (* 15.*) \
break(tty);
(* 6. KEEP FIRST PAGE FOR TTY MESSAGES.*)
firstpage := pagecnt;
needsaneoln := true;
getnextline; ch := ' '; insymbol; reset_possible := false;
new( code_array, pdp10code: code_size );
new( code_reference: code_size );
new( code_relocation: code_size );
%13 (* 14.*)
IF external THEN
BEGIN
lc := low_start; lcmain := lc;
WHILE sfileptr <> NIL DO
WITH sfileptr↑, fileident↑ DO
BEGIN
vaddr := 0; sfileptr := nextftp
END;
sfileptr := fileptr
END;
(* 14.*) \
IF sy = programsy THEN
BEGIN
IF genprocfile THEN
BEGIN
headline := linecnt;
procname_file := source_file;
procname_file[7] := 'P';
procname_file[8] := 'R';
procname_file[9] := 'C';
rewrite(procfile,procname_file);
writeln(procfile,header,' PROC/FUNC LINE NUMBER REPORT OF ',
source_file:6,'.',source_file[7],source_file[8],source_file[9],' ON ',day,' AT ',timeofday);
writeln(procfile);
writeln(procfile,'PROC/FUNC HEAD BEGIN END');
writeln(procfile);
END;
insymbol;
IF sy = ident THEN
BEGIN
programname := id; escape := false;
currname := id;
WHILE (entries < entrymax) AND (sy = ident) AND NOT escape DO
BEGIN
entries := entries + 1;
entry[ entries ] := id;
insymbol;
IF sy = comma THEN
BEGIN
insymbol;
IF sy <> ident THEN
BEGIN
escape := true; error(209)
END
END
ELSE
IF NOT (sy IN [semicolon,lparent]) THEN
BEGIN
escape := true; error(156)
END
END;
IF sy = lparent THEN
BEGIN
REPEAT
insymbol;
IF sy = ident THEN
BEGIN
new(lparmptr);
IF parmptr = NIL THEN parmptr := lparmptr;
WITH lparmptr↑ DO
BEGIN
fileid := id; fileidptr := NIL;
FOR i := 1 TO 2 DO
IF fileid = na[stdfile,i] THEN
BEGIN
fileidptr := stdfileptr[i];
IF i = 1 THEN
inputpar := true
ELSE
outputpar := true;
END;
nextptp := NIL;
IF backwparmptr <> NIL THEN backwparmptr↑.nextptp := lparmptr;
backwparmptr := lparmptr; insymbol;
IF (sy IN [mulop,addop]) AND (op IN [mul,plus]) THEN
BEGIN
IF op = plus THEN error(169);
inputfile := true; insymbol
END
END
END
ELSE (*SY <> IDENT*)
error(209)
UNTIL sy <> comma;
IF sy <> rparent THEN errandskip(152,blockbegsys)
ELSE
BEGIN
insymbol;
skipiferr([semicolon],156,blockbegsys)
END
END
ELSE (*SY <> LPARENT*)
skipiferr([semicolon],156,blockbegsys)
END
ELSE (*SY <> IDENT*)
errandskip(209,blockbegsys)
END
ELSE (*SY <> PROGRAMSY*)
errandskip(318,blockbegsys);
IF sy = semicolon THEN insymbol;
IF NOT errorflag THEN
BEGIN
IF logfile THEN
BEGIN
writeln(list,header,' COMPILATION LOG PRODUCED ON ',day,' AT ',timeofday);
writeln(list,source_file:6,': [',programname,' ]');
writeln(list);
END;
write(tty, ' [ ', programname);
%13 (* 14.*)
IF (entries > 1) AND external THEN
BEGIN
write(tty,': '); i := 2;
LOOP
write(tty,entry[i])
EXIT IF i >= entries;
i := i + 1;
write(tty,', ')
END
END;
(* 14.*) \
(* 6. GIVE PAGE NUMBERS ON TTY.*)
write (tty, ' ] PAGE');
FOR i := firstpage TO pagecnt DO
write (tty, i:3,'..');
break(tty);
%24 NEEDSANEOLN := TRUE; (* 14.*) \
END;
block(NIL,blockbegsys + statbegsys-[casesy],[period,colon]);
errorexit := true; finishline;
111:
IF lptfile OR logfile THEN
BEGIN
writeln(list);
writeln(list,errorcount:4,' ERROR(S) DETECTED');
writeln(list)
END;
writeln(tty);
writeln(tty,errorcount:4,' ERROR(S) DETECTED');
IF errorflag THEN (* 13.*)
no_code_gen := true
%13 (* 14.*)
ELSE
BEGIN
core[1] := highest_code-high_start; core[2] := core[1] MOD 1024;
core[1] := core[1] DIV 1024;
IF lptfile OR logfile THEN
writeln(list,'HIGHSEG: ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
writeln(tty,'HIGHSEG: ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
core[1] := lcmain DIV 1024; core[2] := lcmain MOD 1024;
IF lptfile OR logfile THEN
BEGIN
writeln(list,'LOWSEG : ',core[1]:3,'K + ',core[2]:4,' WORD(S)'); writeln(list)
END;
writeln(tty,'LOWSEG : ',core[1]:3,'K + ',core[2]:4,' WORD(S)');
END (* 14.*) \ ;
dispose( code_array, pdp10code: code_size )
END (* COMPILE *);
PROCEDURE reporttime; (* 22. USE THE LIBRARY PROCEDURES*)
VAR
rtime, elapstime: alfa;
BEGIN (* REPORTTIME *)
runtime(rtime);
elapsedtime (elapstime);
IF lptfile OR logfile THEN
BEGIN
writeln(list);
%24 WRITE (LIST,' COMPILE '); (* 18.*) \
write(list,'RUNTIME: ',rtime,' ':5,'ELAPSED: ',elapstime,tchcnt:10,' CHARS');
END;
writeln(tty);
%24 WRITE (TTY, ' COMPILE '); (* 18.*) \
write(tty,'RUNTIME: ',rtime,' ':5,'ELAPSED: ',elapstime,tchcnt:10,' CHARS');
break(tty);
END (* REPORTTIME *);
%24 (* 15. NEEDED BY PASSGO TO JUMP TO THE USER CODE.*)
PROCEDURE JUMPTO (STARTPOINT, DATASTART, DEBUGDATA,STACKTOP: ADDRRANGE;
PROGNAME: INTEGER);
EXTERN;
(* 15.*) \
(* MAIN BODY *)
BEGIN (*PASCAL*)
settime; (* 22.*)
date(day); time(timeofday);
init_compile;
%24 INITPASSGO; (* 15. INITIALIZE ADDRESSES OF EXTERNALS.*) \
(*ENTER STANDARD NAMES AND STANDARD TYPES:*)
(******************************************)
level := 0; top := 0;
WITH display[0] DO
BEGIN
fname := NIL; occur := blck
END;
enterstdtypes; enterstdnames; enterundecl;
top := 1; level := 1;
WITH display[1] DO
BEGIN
fname := NIL; occur := blck
END;
get_directives;
%13 (* 14. PASCAL VERSION OF THE ACTUAL COMPILING PROCESS.*)
IF NOT option('NOCOMPILE ') THEN
BEGIN
IF lptfile THEN
BEGIN
writeln(list,header,' COMPILATION LIST PRODUCED ON ',
day,' AT ',timeofday,' PAGE 1'); writeln(list)
END;
LOOP
compile
EXIT IF NOT external OR eof(source);
init_compile
END;
END (* IF NOT OPTION('NOCOMPILE ') *);
0:
reporttime;
IF NOT no_code_gen THEN (* 13. ERRORS OF ALL THE FILE, NOT ONLY THE LAST MODULE*)
BEGIN
IF cross_reference OR counting THEN
BEGIN
(* 14. NO LPTFILE IF CROSS_REFERENCE*)
rewrite(tempcore,pcreftmpfile);
i := 1;
WHILE i <= 6 DO
IF source_device[i] = ' ' THEN
i := 7
ELSE
BEGIN
write(tempcore,source_device[i]);
i := i + 1;
END;
write(tempcore,':',source_file:6, '.' ,
source_file[7],source_file[8],source_file[9], ',' ,
source_file:6,'.LST');
FOR i := 1 TO maxpcrefoption DO
IF option (pcrefoption_name [i]) THEN
BEGIN
write (tempcore, '/',pcrefoption_name [i]);
getoption (pcrefoption_name [i], j);
IF j <> 0 THEN
write (tempcore, ':', j:3);
END;
IF NOT counting THEN
BEGIN
(* 1., 4. PASS THE LINKER NAME TO PCREF.*)
IF loadit THEN
BEGIN
writeln (tempcore);
FOR i := 1 TO 6 DO
IF link_device [i] = ' ' THEN
i := 7
ELSE
write (tempcore, link_device [i]);
write(tempcore,':');
FOR i := 1 TO 6 DO
IF linker_file [i] = ' ' THEN
i := 7
ELSE
write (tempcore, linker_file[i]);
writeln (tempcore,'!');
END;
call(pcreffile,pcrefdevice,pcrefppn,pcrefcore); (* 4.*)
END;
END;
IF loadit THEN
BEGIN
writeln(tty); break(tty);
call(linker_file,link_device) (* 1.*)
END
END
ELSE
BEGIN
rewrite(object);
%12
REWRITE(TEMPCORE,LINK_TMPFILE);
\
writeln(tty);
writeln(tty,'EXECUTION SUPPRESSED');
END;
\
%1
WRITE (TTY,BEL);
(* 14. END OF THE PASCAL VERSION OF THE ACTUAL COMPILING PROCESS.*) \
%24 (* 15. PASSGO VERSION OF THE ACTUAL COMPILING AND EXECUTING PROCESS.*)
IF LPTFILE THEN
BEGIN
WRITELN (LIST,HEADER,' COMPILATION LIST PRODUCED ON '
,DAY,' AT ', TIMEOFDAY,' PAGE 1'); WRITELN(LIST);
END;
(* 26. SHOW RUNTIME MAPPING.*)
IF OPTION('SHOW ') THEN
BEGIN
WRITELN(TTY,'RUNTIME PROCEDURES: ');
FOR I := 1 TO NAMAX[DECLPROC] DO
WRITELN(TTY,NA[DECLPROC,I],': ',EXTADDR[DECLPROC,I]:6:O);
WRITELN(TTY);
WRITELN(TTY,'PREDEFINED FUNCTIONS:');
FOR I := 1 TO NAMAX[DECLFUNC] DO
WRITELN(TTY,NA[DECLFUNC,I],': ',EXTADDR[DECLFUNC,I]:6:O);
WRITELN(TTY);
WRITELN(TTY,'RUNTIMES:');
FOR SUPTINDEX := FIRST(SUPTINDEX) TO LAST(SUPTINDEX) DO
WRITELN(TTY,RUNTIME_SUPPORT.NAME[SUPTINDEX]:7,': ',RUNTIME_SUPPORT.LINK[SUPTINDEX]:6:O);
END;
COMPILE;
0:
IF NOT NO_CODE_GEN THEN
BEGIN
(* 26. SHOW MEMORY ORGANIZATION.*)
IF OPTION('SHOW ') THEN
BEGIN
WRITELN(TTY,'USER PROGRAM ARRAY SIZE: ',MAXCODE:6:O,'B');
WRITELN(TTY,'FILE DATA START : ',USERAREASTART:6:O,'B');
WRITELN(TTY,' END : ',FILELC:6:O,'B');
WRITELN(TTY,'CODE START : ',USERAREASTART+MAXFILECODE:6:O,'B');
WRITELN(TTY,' END : ',IC:6:O,'B');
WRITELN(TTY,' ENTRY POINT : ',START_ADDRESS:6:O,'B');
WRITELN(TTY,'DATA START : ',DATASTART:6:O,'B');
WRITELN(TTY,' END : ',LCMAIN:6:O,'B');
REWRITE(OBJECT,'OBJECTREL'); (* PSEUDO REL FILE FOR DEBUGGING *)
WITH USERPROG DO
BEGIN
WITH CHANGE DO (* START ADDRESS BLOCK *)
BEGIN
WLEFTHALF := 7;
WRIGHTHALF := 1;
OBJECT↑ := WKONST;
PUT(OBJECT);
OBJECT↑ := 0;
PUT(OBJECT);
OBJECT↑ := START_ADDRESS;
PUT(OBJECT);
END;
I := MAXFILECODE;
WHILE (I + USERAREASTART) < HIGHEST_CODE DO (* CODE BLOCKS*)
BEGIN
WITH CHANGE DO (* HEADER: BLOCK TYPE AND SIZE *)
BEGIN
WLEFTHALF := 1;
WRIGHTHALF := 22B;
OBJECT↑ := WKONST;
PUT(OBJECT);
END;
OBJECT↑ := 0; (* RELOCATION WORD AND ADDRESS *)
PUT(OBJECT);
OBJECT↑ := USERAREASTART + I;
PUT(OBJECT);
FOR J := I TO I + 20B DO (* CODE *)
BEGIN
IF (J + USERAREASTART) < HIGHEST_CODE THEN
OBJECT↑ := EXECODE[J]
ELSE
OBJECT↑ := 377777777777B;
PUT(OBJECT);
END;
I := I + 21B;
END;
I := 0; (* FILE DESCRIPTOR BLOCKS *)
WHILE (I + USERAREASTART) < FILELC DO
BEGIN
WITH CHANGE DO (* HEADER: BLOCK TYPE AND SIZE *)
BEGIN
WLEFTHALF := 1;
WRIGHTHALF := 22B;
OBJECT↑ := WKONST;
PUT(OBJECT);
END;
OBJECT↑ := 0; (* RELOCATION WORD AND ADDRESS *)
PUT(OBJECT);
OBJECT↑ := USERAREASTART + I;
PUT(OBJECT);
FOR J := I TO I + 20B DO (* DATA *)
BEGIN
IF (J + USERAREASTART) < FILELC THEN
OBJECT↑ := EXECODE [J]
ELSE
OBJECT↑ := 377777777777B;
PUT(OBJECT);
END;
I := I+21B;
END;
RESET(OBJECT);
END;
END;
IF CROSS_REFERENCE THEN
BEGIN
REWRITE(TEMPCORE,PCREFTMPFILE);
I := 1;
WHILE I <= 6 DO
IF SOURCE_DEVICE[I] = ' ' THEN
I := 7
ELSE
BEGIN
WRITE(TEMPCORE,SOURCE_DEVICE[I]);
I := I + 1;
END;
WRITE(TEMPCORE,':');
WRITE(TEMPCORE,SOURCE_FILE:6, '.' ,
SOURCE_FILE[7],SOURCE_FILE[8],SOURCE_FILE[9], ',' ,
SOURCE_FILE:6,'.LST');
FOR I := 1 TO MAXPCREFOPTION DO
IF OPTION (PCREFOPTION_NAME [I]) THEN
BEGIN
WRITE (TEMPCORE, '/',PCREFOPTION_NAME [I]);
GETOPTION (PCREFOPTION_NAME [I], J);
IF J <> 0 THEN
WRITE (TEMPCORE, ':', J:3);
END;
WRITELN (TEMPCORE);
RESET (TEMPCORE);
END;
IF GENPROCFILE THEN
RESET(PROCFILE);
FOR I := 1 TO 6 DO
CHANGE.WSIXBIT[I] := ORD(PROGRAMNAME[I]) - 40B;
REENTER;
REPORTTIME;
IF LPTFILE AND NOT CROSS_REFERENCE THEN
RESET(LIST);
WRITELN(TTY);
WRITELN(TTY,PROGRAMNAME,': EXECUTION');
BREAK(TTY);
JUMPTO (START_ADDRESS, DATASTART, USERAREASTART + DEBUG_SAVE, LCMAIN + 2,CHANGE.WKONST);
END
ELSE
BEGIN
REPORTTIME;
IF LPTFILE THEN
BEGIN
WRITELN(LIST); WRITELN(LIST,'EXECUTION SUPPRESSED.');
END;
WRITELN(TTY); WRITELN(TTY,'EXECUTION SUPPRESSED.' \ %2 ,BEL \ %24 );
END;
(* 15. END OF PASSGO VERSION OF THE ACTUAL COMPILE AND EXECUTING PROCESS.*) \
END (*PASCAL*).